From 6679b7e5a515bff5b1c5235ab0dea8c67f86264c Mon Sep 17 00:00:00 2001 From: "waldemar%netscape.com" Date: Thu, 5 Jun 2003 01:36:19 +0000 Subject: [PATCH] Numerous algorithm fixes, changes, and additions. Supported the primitive classes. --- js2/semantics/JS20/Parser.lisp | 2399 ++++++++++++++++++++++++-------- 1 file changed, 1791 insertions(+), 608 deletions(-) diff --git a/js2/semantics/JS20/Parser.lisp b/js2/semantics/JS20/Parser.lisp index a49b88b0d681..faa1b4d4e74b 100644 --- a/js2/semantics/JS20/Parser.lisp +++ b/js2/semantics/JS20/Parser.lisp @@ -20,14 +20,15 @@ (deftype semantic-exception (union object control-transfer)) - (%heading (2 :semantics) "String to Number Conversion") + (%heading (2 :semantics) "Extended integers and rationals") (deftag +zero) (deftag -zero) (deftag +infinity) (deftag -infinity) (deftag nan) - (deftype extended-rational (union rational (tag +zero -zero +infinity -infinity nan))) + (deftype extended-rational (union (exclude-zero rational) (tag +zero -zero +infinity -infinity nan))) + (deftype extended-integer (union integer (tag +infinity -infinity nan))) (deftag syntax-error) @@ -39,6 +40,7 @@ (deftype object (union undefined null boolean long u-long float32 float64 char16 string namespace compound-attribute class simple-instance method-closure date reg-exp package)) (deftype primitive-object (union undefined null boolean long u-long float32 float64 char16 string)) + (deftype nonprimitive-object (union namespace compound-attribute class simple-instance method-closure date reg-exp package)) (deftype binding-object (union class simple-instance reg-exp date package)) (deftype object-opt (union object (tag none))) @@ -97,8 +99,8 @@ (%heading (3 :semantics) "Classes") (defrecord class (local-bindings (list-set local-binding) :var) - (super class-opt) (instance-properties (list-set instance-property) :var) + (super class-opt) (prototype object-opt :opt-const) (complete boolean :var) (name string) @@ -107,6 +109,7 @@ (dynamic boolean) (final boolean) (default-value object-opt) + (default-hint hint :opt-const) (bracket-read (-> (object class (vector object) phase) object-opt)) (bracket-write (-> (object class (vector object) object (tag run)) (tag none ok))) (bracket-delete (-> (object class (vector object) (tag run)) boolean-opt)) @@ -118,17 +121,17 @@ (construct (-> ((vector object) phase) object) :opt-const) (init (union (-> (simple-instance (vector object) (tag run)) void) (tag none)) :var) (is (-> (object class) boolean)) - (implicit-coerce (-> (object class boolean) object))) + (as (-> (object class boolean) object))) (deftype class-opt (union class (tag none))) (%heading (3 :semantics) "Simple Instances") (defrecord simple-instance (local-bindings (list-set local-binding) :var) - (super object-opt) - (sealed boolean) + (archetype object-opt :opt-const) + (sealed boolean :var) (type class) - (slots (list-set slot) :var) + (slots (list-set slot)) (call (union (-> (object simple-instance (vector object) phase) object) (tag none))) (construct (union (-> (simple-instance (vector object) phase) object) (tag none))) (env environment-opt)) @@ -152,22 +155,23 @@ (%heading (3 :semantics) "Method Closures") (deftuple method-closure (this object) - (method instance-method)) + (method instance-method) + (slots (list-set slot))) (%heading (3 :semantics) "Dates") (defrecord date (local-bindings (list-set local-binding) :var) - (super object-opt) - (sealed boolean) + (archetype object-opt) + (sealed boolean :var) (time-value integer)) (%heading (3 :semantics) "Regular Expressions") (defrecord reg-exp (local-bindings (list-set local-binding) :var) - (super object-opt) - (sealed boolean) + (archetype object-opt) + (sealed boolean :var) (source string) (last-index integer) (global boolean) @@ -178,8 +182,10 @@ (%heading (3 :semantics) "Packages") (defrecord package (local-bindings (list-set local-binding) :var) - (super object-opt) - (sealed boolean) + (archetype object-opt) + (name string) + (initialize (union (-> () void) (tag none busy)) :var) + (sealed boolean :var) (internal-namespace namespace)) @@ -202,7 +208,7 @@ (deftuple dot-reference (base object) (limit class) - (property-multiname multiname)) + (multiname multiname)) (deftuple bracket-reference (base object) @@ -305,16 +311,16 @@ (deftype variable-value (union (tag none) object uninstantiated-function)) (deftag busy) - (deftype initialiser (-> (environment phase) object)) - (deftype initialiser-opt (union initialiser (tag none))) + (deftype initializer (-> (environment phase) object)) + (deftype initializer-opt (union initializer (tag none))) (defrecord variable (type class :opt-const) (value variable-value :var) (immutable boolean) (setup (union (-> () class-opt) (tag none busy)) :var) - (initialiser (union initialiser (tag none busy)) :var) - (initialiser-env environment :opt-const)) + (initializer (union initializer (tag none busy)) :var) + (initializer-env environment :opt-const)) (deftype variable-opt (union variable (tag none))) (defrecord dynamic-var @@ -336,7 +342,7 @@ (defrecord instance-variable (multiname multiname :opt-const) (final boolean) - (enumerable boolean) + (enumerable boolean :opt-const) (type class :opt-const) (default-value object-opt :opt-const) (immutable boolean)) @@ -345,28 +351,42 @@ (defrecord instance-method (multiname multiname :opt-const) (final boolean) - (enumerable boolean) - (signature parameter-frame) + (enumerable boolean :opt-const) + (signature parameter-frame :opt-const) + (length integer) (call (-> (object (vector object) phase) object))) (defrecord instance-getter (multiname multiname :opt-const) (final boolean) - (enumerable boolean) - (signature parameter-frame) + (enumerable boolean :opt-const) + (signature parameter-frame :opt-const) (call (-> (object phase) object))) (defrecord instance-setter (multiname multiname :opt-const) (final boolean) - (enumerable boolean) - (signature parameter-frame) + (enumerable boolean :opt-const) + (signature parameter-frame :opt-const) (call (-> (object object phase) void))) (deftype property-opt (union singleton-property instance-property (tag none))) + (%heading (2 :semantics) "Miscellaneous") + (deftag hint-string) + (deftag hint-number) + (deftype hint (tag hint-string hint-number)) + (deftype hint-opt (union hint (tag none))) + + (deftag less) + (deftag equal) + (deftag greater) + (deftag unordered) + (deftype order (tag less equal greater unordered)) + + (%heading (1 :semantics) "Data Operations") (%heading (2 :semantics) "Numeric Utilities") @@ -396,15 +416,25 @@ (<- j (- j (expt 2 64)))) (return j)) - (%text :comment (:global-call truncate-to-integer x) " returns " (:local x) " converted to an integer by rounding towards zero. If " (:local x) - " is an infinity or a NaN, the result is 0.") - (define (truncate-to-integer (x general-number)) integer + (%text :comment (:global-call truncate-to-extended-integer x) " returns " (:local x) " converted to an integer by rounding towards zero. If " (:local x) + " is an infinity or a NaN, the result is " (:tag +infinity) ", " (:tag -infinity) ", or " (:tag nan) ", as appropriate.") + (define (truncate-to-extended-integer (x general-number)) extended-integer (case x - (:select (tag +infinity32 +infinity64 -infinity32 -infinity64 nan32 nan64) (return 0)) + (:select (tag +infinity32 +infinity64) (return +infinity)) + (:select (tag -infinity32 -infinity64) (return -infinity)) + (:select (tag nan32 nan64) (return nan)) (:narrow finite-float32 (return (truncate-finite-float32 x))) (:narrow finite-float64 (return (truncate-finite-float64 x))) (:narrow (union long u-long) (return (& value x))))) + (%text :comment (:global-call truncate-to-integer x) " returns " (:local x) " converted to an integer by rounding towards zero. If " (:local x) + " is an infinity or a NaN, the result is 0.") + (define (truncate-to-integer (x general-number)) integer + (const i extended-integer (truncate-to-extended-integer x)) + (case i + (:select (tag +infinity -infinity nan) (return 0)) + (:narrow integer (return i)))) + (%text :comment (:global-call check-integer x) " returns " (:local x) " converted to an integer if its mathematical value is, in fact, an integer. " "If " (:local x) " is an infinity or a NaN or has a fractional part, the result is " (:tag none) ".") (define (check-integer (x general-number)) integer-opt @@ -490,6 +520,19 @@ (:select (tag +zero32 +zero64 -zero32 -zero64) (return 0)) (:narrow (union nonzero-finite-float32 nonzero-finite-float64 long u-long) (return (& value x))))) + (%text :comment (:global-call to-float32 x) " converts " (:local x) " to a " (:type float32) ", using the IEEE 754 " + :left-double-quote "round to nearest" :right-double-quote " mode.") + (define (to-float32 (x general-number)) float32 + (case x + (:narrow (union long u-long) (return (real-to-float32 (& value x)))) + (:narrow float32 (return x)) + (:select (tag -infinity64) (return -infinity32)) + (:select (tag -zero64) (return -zero32)) + (:select (tag +zero64) (return +zero32)) + (:select (tag +infinity64) (return +infinity32)) + (:select (tag nan64) (return nan32)) + (:narrow nonzero-finite-float64 (return (real-to-float32 (& value x)))))) + (%text :comment (:global-call to-float64 x) " converts " (:local x) " to a " (:type float64) ", using the IEEE 754 " :left-double-quote "round to nearest" :right-double-quote " mode.") (define (to-float64 (x general-number)) float64 @@ -499,12 +542,6 @@ (:narrow float64 (return x)))) - (deftag less) - (deftag equal) - (deftag greater) - (deftag unordered) - (deftype order (tag less equal greater unordered)) - (%text :comment (:global-call general-number-compare x y) " compares " (:local x) " with " (:local y) " using the IEEE 754 rules and returns " (:tag less) " if " (:local x) "<" (:local y) ", " (:tag equal) " if " (:local x) "=" (:local y) ", " (:tag greater) " if " (:local x) ">" (:local y) ", or " (:tag unordered) " if either " (:local x) " or " (:local y) " is a NaN. The comparison is done using the exact values of " (:local x) " and " (:local y) @@ -531,8 +568,51 @@ (nil (return equal)))))) + (%heading (2 :semantics) "Character Utilities") + + (define (integer-to-u-t-f16 (i (integer-range 0 (hex #x10FFFF)))) string + (cond + ((cascade integer 0 <= i <= (hex #xFFFF)) + (return (vector (integer-to-char16 i)))) + (nil + (const j (integer-range 0 (hex #xFFFFF)) (- i (hex #x10000))) + (const high char16 (integer-to-char16 (+ (hex #xD800) (bitwise-shift j -10)))) + (const low char16 (integer-to-char16 (+ (hex #xDC00) (bitwise-and j (hex #x3FF))))) + (return (vector high low))))) + + + (define (char-to-lower-full (ch char16)) string + (/* (:keyword return) " " (:local ch) " converted to a lower case character using the Unicode full, locale-independent case mapping. " + "A single character may be converted to multiple characters. If " (:local ch) " has no lower case equivalent, then the result is the string " + (:expr string (vector ch)) ".") + (return (vector (lisp-call char-downcase (ch) char16)))) + + + (define (char-to-lower-localized (ch char16)) string + (/* (:keyword return) " " (:local ch) " converted to a lower case character using the Unicode full case mapping in the host environment" :apostrophe + "s current locale. " + "A single character may be converted to multiple characters. If " (:local ch) " has no lower case equivalent, then the result is the string " + (:expr string (vector ch)) ".") + (return (vector (lisp-call char-downcase (ch) char16)))) + + + (define (char-to-upper-full (ch char16)) string + (/* (:keyword return) " " (:local ch) " converted to a upper case character using the Unicode full, locale-independent case mapping. " + "A single character may be converted to multiple characters. If " (:local ch) " has no upper case equivalent, then the result is the string " + (:expr string (vector ch)) ".") + (return (vector (lisp-call char-upcase (ch) char16)))) + + + (define (char-to-upper-localized (ch char16)) string + (/* (:keyword return) " " (:local ch) " converted to a upper case character using the Unicode full case mapping in the host environment" :apostrophe + "s current locale. " + "A single character may be converted to multiple characters. If " (:local ch) " has no upper case equivalent, then the result is the string " + (:expr string (vector ch)) ".") + (return (vector (lisp-call char-downcase (ch) char16)))) + + (%heading (2 :semantics) "Object Utilities") - (%heading (3 :semantics) (:global object-type nil)) + (%heading (3 :semantics) "Object Class Inquiries") (%text :comment (:global-call object-type o) " returns an " (:type object) " " (:local o) :apostrophe "s most specific type. Although " (:global object-type) " is used internally throughout this specification, in order to allow one programmer-visible class to be implemented as an " "ensemble of implementation-specific classes, no way is provided for a user program to directly obtain the result of calling " (:global object-type) @@ -558,7 +638,6 @@ (:select package (return -package)))) - (%heading (3 :semantics) (:global is nil)) (%text :comment (:global-call is o c) " returns " (:tag true) " if " (:local o) " is an instance of class " (:local c) " or one of its subclasses.") (define (is (o object) (c class)) boolean (return ((& is c) o c))) @@ -593,9 +672,9 @@ |# - (%heading (3 :semantics) (:global to-boolean nil)) - (%text :comment (:global-call to-boolean o phase) " returns " (:local o) " coerced to a " (:global -boolean) ". The " (:local phase) " argument is ignored.") - (define (to-boolean (o object) (phase phase :unused)) boolean + (%heading (3 :semantics) "Object to Boolean Conversion") + (%text :comment (:global-call object-to-boolean o) " returns " (:local o) " converted to a " (:global -boolean) ".") + (define (object-to-boolean (o object)) boolean (case o (:select (union undefined null) (return false)) (:narrow boolean (return o)) @@ -606,23 +685,125 @@ (:select (union char16 namespace compound-attribute class simple-instance method-closure date reg-exp package) (return true)))) - (%heading (3 :semantics) (:global to-general-number nil)) - (%text :comment (:global-call to-general-number o phase) " returns " (:local o) " coerced to a " (:global -general-number) ". If " + (%heading (3 :semantics) "Object to Primitive Conversion") + (define (object-to-primitive (o object) (hint hint-opt) (phase phase)) primitive-object + (rwhen (in o primitive-object :narrow-true) + (return o)) + (const c class (object-type o)) + (var h hint) + (if (in hint hint :narrow-true) + (<- h hint) + (<- h (&opt default-hint c))) + (case h + (:select (tag hint-string) + (const to-string-method object-opt ((& read c) o c (list-set (new qualified-name public "toString")) none phase)) + (when (not-in to-string-method (tag none) :narrow-true) + (const r object (call o to-string-method (vector-of object) phase)) + (rwhen (in r primitive-object :narrow-true) + (return r))) + (const value-of-method object-opt ((& read c) o c (list-set (new qualified-name public "valueOf")) none phase)) + (when (not-in value-of-method (tag none) :narrow-true) + (const r object (call o value-of-method (vector-of object) phase)) + (rwhen (in r primitive-object :narrow-true) + (return r)))) + (:select (tag hint-number) + (const value-of-method object-opt ((& read c) o c (list-set (new qualified-name public "valueOf")) none phase)) + (when (not-in value-of-method (tag none) :narrow-true) + (const r object (call o value-of-method (vector-of object) phase)) + (rwhen (in r primitive-object :narrow-true) + (return r))) + (const to-string-method object-opt ((& read c) o c (list-set (new qualified-name public "toString")) none phase)) + (when (not-in to-string-method (tag none) :narrow-true) + (const r object (call o to-string-method (vector-of object) phase)) + (rwhen (in r primitive-object :narrow-true) + (return r))))) + (throw-error -type-error "cannot convert this object to a primitive")) + + + (%heading (3 :semantics) "Object to Number Conversions") + (%text :comment (:global-call object-to-general-number o phase) " returns " (:local o) " converted to a " (:global -general-number) ". If " (:local phase) " is " (:tag compile) ", only constant conversions are permitted.") - (define (to-general-number (o object) (phase phase)) general-number - (case o + (define (object-to-general-number (o object) (phase phase)) general-number + (var a primitive-object) + (if (in o primitive-object :narrow-true) + (<- a o) + (<- a (object-to-primitive o hint-number phase))) + (case a (:select undefined (return nan64)) (:select (union null (tag false)) (return +zero64)) (:select (tag true) (return 1.0)) - (:narrow general-number (return o)) - (:select (union char16 string) (return (string-to-general-number (to-string o phase)))) - (:select (union namespace compound-attribute class method-closure package) (throw-error -type-error)) - (:select simple-instance (todo)) - (:select date (todo)) - (:select reg-exp (todo)))) + (:narrow general-number (return a)) + (:narrow (union char16 string) (return (string-to-float64 (to-string a)))))) - (define (string-to-general-number (s string)) general-number + (%text :comment (:global-call object-to-float32 o phase) " returns " (:local o) " converted to a " (:type float32) ". If " + (:local phase) " is " (:tag compile) ", only constant conversions are permitted.") + (define (object-to-float32 (o object) (phase phase)) float32 + (var a primitive-object) + (if (in o primitive-object :narrow-true) + (<- a o) + (<- a (object-to-primitive o hint-number phase))) + (case a + (:select undefined (return nan32)) + (:select (union null (tag false)) (return +zero32)) + (:select (tag true) (return (float32 1.0))) + (:narrow general-number (return (to-float32 a))) + (:narrow (union char16 string) (return (string-to-float32 (to-string a)))))) + + + (%text :comment (:global-call object-to-float64 o phase) " returns " (:local o) " converted to a " (:type float64) ". If " + (:local phase) " is " (:tag compile) ", only constant conversions are permitted.") + (define (object-to-float64 (o object) (phase phase)) float64 + (return (to-float64 (object-to-general-number o phase)))) + + + (%text :comment (:global-call object-to-imprecise-integer o phase) " returns " (:local o) " converted to an " (:type extended-integer) ". If " + (:local o) " has a fractional part, it is truncated towards zero. If " (:local o) " is a string, then it is converted to a " (:type float64) + " first, which may cause loss of precision. If " + (:local phase) " is " (:tag compile) ", only constant conversions are permitted.") + (define (object-to-imprecise-integer (o object) (phase phase)) extended-integer + (return (truncate-to-extended-integer (object-to-general-number o phase)))) + + + (%text :comment (:global-call object-to-precise-integer o phase) " returns " (:local o) " converted to an " (:type integer) ". An error occurs if " + (:local o) " has a fractional part or is not finite. If " (:local o) " is a string, then it is converted exactly. If " + (:local phase) " is " (:tag compile) ", only constant conversions are permitted.") + (define (object-to-precise-integer (o object) (phase phase)) integer + (var a primitive-object) + (if (in o primitive-object :narrow-true) + (<- a o) + (<- a (object-to-primitive o hint-number phase))) + (case a + (:select (union undefined null null (tag false)) (return 0)) + (:select (tag true) (return 1)) + (:narrow general-number + (const i integer-opt (check-integer a)) + (if (in i (tag none) :narrow-false) + (throw-error -range-error (:local a) " is not finite") + (return i))) + (:narrow (union char16 string) + (const i integer-opt (string-to-integer (to-string a) 10)) + (if (in i (tag none) :narrow-false) + (throw-error -type-error "the string " (:local a) " does not contain an integer literal") + (return i))))) + + + (define (string-to-float32 (s string)) float32 + (const q (union extended-rational (tag syntax-error)) + (lisp-call string-to-extended-rational (s) + (union extended-rational (tag syntax-error)) + "the result of parsing " (:operand 0) " using " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " as the start symbol")) + (case q + (:select (tag syntax-error) (return nan32)) + (:narrow rational (return (real-to-float32 q))) + (:select (tag +zero) (return +zero32)) + (:select (tag -zero) (return -zero32)) + (:select (tag +infinity) (return +infinity32)) + (:select (tag -infinity) (return -infinity32)) + (:select (tag nan) (return nan32)))) + + + (define (string-to-float64 (s string)) float64 (const q (union extended-rational (tag syntax-error)) (lisp-call string-to-extended-rational (s) (union extended-rational (tag syntax-error)) @@ -637,28 +818,39 @@ (:select (tag nan) (return nan64)))) - (%heading (3 :semantics) (:global to-string nil)) - (%text :comment (:global-call to-string o phase) " returns " (:local o) " coerced to a " (:global -string) ". If " + (define (string-to-integer (s string :unused) (radix integer :unused)) integer-opt + (todo)) + + + (%heading (3 :semantics) "Object to String Conversions") + (%text :comment (:global-call object-to-string o phase) " returns " (:local o) " converted to a " (:global -string) ". If " (:local phase) " is " (:tag compile) ", only constant conversions are permitted.") - (define (to-string (o object) (phase phase :unused)) string - (case o + (define (object-to-string (o object) (phase phase)) string + (var a primitive-object) + (if (in o primitive-object :narrow-true) + (<- a o) + (<- a (object-to-primitive o hint-string phase))) + (case a (:select undefined (return "undefined")) (:select null (return "null")) (:select (tag false) (return "false")) (:select (tag true) (return "true")) - (:narrow (union long u-long) (return (integer-to-string (& value o)))) - (:narrow float32 (return (float32-to-string o))) - (:narrow float64 (return (float64-to-string o))) + (:narrow general-number (return (general-number-to-string a))) + (:narrow char16 (return (vector a))) + (:narrow string (return a)))) + + + (define (to-string (o (union char16 string))) string + (case o (:narrow char16 (return (vector o))) - (:narrow string (return o)) - (:select namespace (todo)) - (:select compound-attribute (todo)) - (:select class (todo)) - (:select method-closure (todo)) - (:select simple-instance (todo)) - (:select date (todo)) - (:select reg-exp (todo)) - (:select package (todo)))) + (:narrow string (return o)))) + + + (define (general-number-to-string (x general-number)) string + (case x + (:narrow (union long u-long) (return (integer-to-string (& value x)))) + (:narrow float32 (return (float32-to-string x))) + (:narrow float64 (return (float64-to-string x))))) (%text :comment (:global-call integer-to-string i) " converts an integer " (:local i) " to a string of one or more decimal digits. If " @@ -776,32 +968,24 @@ (defprimitive float64-to-string (lambda (x) (float64-to-string x))) - (%heading (3 :semantics) (:global to-qualified-name nil)) - (%text :comment (:global-call to-qualified-name o phase) " coerces an object " (:local o) " to a qualified name. If " + (%heading (3 :semantics) "Object to Qualified Name Conversion") + (%text :comment (:global-call object-to-qualified-name o phase) " coerces an object " (:local o) " to a qualified name. If " (:local phase) " is " (:tag compile) ", only constant conversions are permitted.") - (define (to-qualified-name (o object) (phase phase)) qualified-name - (return (new qualified-name public (to-string o phase)))) + (define (object-to-qualified-name (o object) (phase phase)) qualified-name + (return (new qualified-name public (object-to-string o phase)))) - (%heading (3 :semantics) (:global to-primitive nil)) - (define (to-primitive (o object) (hint object :unused) (phase phase)) primitive-object - (case o - (:narrow primitive-object (return o)) - (:select (union namespace compound-attribute class simple-instance method-closure reg-exp package) (return (to-string o phase))) - (:narrow date (todo)))) - - - (%heading (3 :semantics) (:global to-class nil)) - (%text :comment (:global-call to-class o) " returns " (:local o) " coerced to a non-" (:tag null) " " (:global -class) ".") - (define (to-class (o object)) class + (%heading (3 :semantics) "Object to Class Conversion") + (%text :comment (:global-call object-to-class o) " returns " (:local o) " converted to a non-" (:tag null) " " (:global -class) ".") + (define (object-to-class (o object)) class (if (in o class :narrow-true) (return o) (throw-error -type-error))) - (%heading (3 :semantics) (:global to-attribute nil)) - (%text :comment (:global-call to-attribute o) " returns " (:local o) " coerced to an attribute.") - (define (to-attribute (o object) (phase phase)) attribute + (%heading (3 :semantics) "Object to Attribute Conversion") + (%text :comment (:global-call object-to-attribute o) " returns " (:local o) " converted to an attribute.") + (define (object-to-attribute (o object) (phase phase)) attribute (cond ((in o attribute :narrow-true) (return o)) (nil @@ -812,29 +996,20 @@ (throw-error -type-error))))) - (%heading (3 :semantics) (:global implicit-coerce nil)) - (%text :comment (:global-call implicit-coerce o c silent) " attempts to implicitly coerce " (:local o) " to class " (:local c) ". If the coercion succeeds, " - (:global implicit-coerce) " returns the coerced value. If not, then " (:global implicit-coerce) " returns " (:tag null) " if " (:local silent) " is " (:tag true) - " and " (:tag null) " is a member of type " (:local c) "; otherwise, " (:global implicit-coerce) " throws a " (:global -type-error) ".") + (%heading (3 :semantics) "Implicit Coercions") + (%text :comment (:global-call as o c silent) " attempts to implicitly coerce " (:local o) " to class " (:local c) ". If the coercion succeeds, " + (:global as) " returns the coerced value. If not, then " (:global as) " returns " (:tag null) " if " (:local silent) " is " (:tag true) + " and " (:tag null) " is a member of type " (:local c) "; otherwise, " (:global as) " throws a " (:global -type-error) ".") (%text :comment "The coercion always succeeds and returns " (:local o) " unchanged if " (:local o) " is already a member of class " (:local c) ". The value returned from " - (:global implicit-coerce) " always is a member of class " (:local c) ".") - (define (implicit-coerce (o object) (c class) (silent boolean)) object - (return ((& implicit-coerce c) o c silent))) + (:global as) " always is a member of class " (:local c) ".") + (define (as (o object) (c class) (silent boolean)) object + (return ((& as c) o c silent))) - (%text :comment (:global-call ordinary-implicit-coerce-no-null o c) " is the implementation of " (:global implicit-coerce) " for a native class that does not have " + (%text :comment (:global-call ordinary-as o c) " is the implementation of " (:global as) " for a native class that has " (:local null) " as a member, unless specified otherwise in the class" :apostrophe - "s definition. Such host classes may either also use " (:global ordinary-implicit-coerce-no-null) " or define a different procedure to perform this coercion.") - (define (ordinary-implicit-coerce-no-null (o object) (c class) (silent boolean :unused)) object - (if (is o c) - (return o) - (throw-error -type-error))) - - - (%text :comment (:global-call ordinary-implicit-coerce-null o c) " is the implementation of " (:global implicit-coerce) " for a native class that has " - (:local null) " as a member, unless specified otherwise in the class" :apostrophe - "s definition. Such host classes may either also use " (:global ordinary-implicit-coerce-no-null) " or define a different procedure to perform this coercion.") - (define (ordinary-implicit-coerce-null (o object) (c class) (silent boolean)) object + "s definition. Host classes may define a different procedure to perform this coercion.") + (define (ordinary-as (o object) (c class) (silent boolean)) object (cond ((or (in o (tag null)) (is o c)) (return o)) (silent (return null)) @@ -891,9 +1066,8 @@ (in accesses2 (tag read-write))))) - (define (object-super (o object)) object-opt + (define (archetype (o object)) object-opt (case o - (:narrow binding-object (return (& super o))) (:select (union undefined null) (return none)) (:select boolean (return (&opt prototype -boolean))) (:select long (return (&opt prototype \#long))) @@ -904,23 +1078,23 @@ (:select string (return (&opt prototype -string))) (:select namespace (return (&opt prototype -namespace))) (:select compound-attribute (return (&opt prototype -attribute))) - (:select method-closure (return (&opt prototype -function))))) + (:select method-closure (return (&opt prototype -function))) + (:select class (return (&opt prototype -class))) + (:narrow (union simple-instance reg-exp date package) (return (&opt archetype o))))) - (%text :comment (:global-call object-supers o) " returns the set of " (:local o) :apostrophe "s superobjects, not including " (:local o) " itself.") - (define (object-supers (o object)) (list-set object) - (rwhen (not-in o binding-object :narrow-false) + (%text :comment (:global-call archetypes o) " returns the set of " (:local o) :apostrophe "s archetypes, not including " (:local o) " itself.") + (define (archetypes (o object)) (list-set object) + (const a object-opt (archetype o)) + (rwhen (in a (tag none) :narrow-false) (return (list-set-of object))) - (const super object-opt (object-super o)) - (rwhen (in super (tag none) :narrow-false) - (return (list-set-of object))) - (return (set+ (list-set super) (object-supers super)))) + (return (set+ (list-set a) (archetypes a)))) (%text :comment (:local o) " is an object that is known to have slot " (:local id) ". " (:global-call find-slot o id) " returns that slot.") (define (find-slot (o object) (id instance-variable)) slot - (assert (in o simple-instance :narrow-true) - (:local o) " must be a " (:type simple-instance) " in order to have slots.") + (assert (in o (union simple-instance method-closure) :narrow-true) + (:local o) " must be a " (:type simple-instance) " or a " (:type method-closure) " in order to have slots.") (const matching-slots (list-set slot) (map (& slots o) s s (= (& id s) id instance-variable))) (return (unique-elt-of matching-slots))) @@ -936,24 +1110,25 @@ (var type class-opt (setup)) (when (in type (tag none)) (<- type -object)) - (&const= type v (assert-not-in type (tag none))) + (quiet-assert (not-in type (tag none) :narrow-true)) + (&const= type v type) (&= setup v none)) (:select (tag none)) (:select (tag busy) (throw-error -constant-error "a constant" :apostrophe "s type or initialiser cannot depend on the value of that constant")))) - (%text :comment (:def-const v variable) (:global-call write-variable v new-value clear-initialiser) " writes the value " (:local new-value) " into the mutable or immutable variable " - (:local v) ". " (:local new-value) " is coerced to " (:local v) :apostrophe "s type. If the " (:local clear-initialiser) " flag is set, then the caller " + (%text :comment (:def-const v variable) (:global-call write-variable v new-value clear-initializer) " writes the value " (:local new-value) " into the mutable or immutable variable " + (:local v) ". " (:local new-value) " is coerced to " (:local v) :apostrophe "s type. If the " (:local clear-initializer) " flag is set, then the caller " " has just evaluated " (:local v) :apostrophe "s initialiser and is supplying its result in " (:local new-value) ". In this case " (:global write-variable) - " atomically clears " (:expr (union initialiser (tag none busy)) (& initialiser v)) " while writing " + " atomically clears " (:expr (union initializer (tag none busy)) (& initializer v)) " while writing " (:expr variable-value (& value v)) ". In all other cases the presence of an initialiser or an existing value will prevent an immutable variable" :apostrophe "s value from being written.") - (define (write-variable (v variable) (new-value object) (clear-initialiser boolean)) object - (const coerced-value object (implicit-coerce new-value (&opt type v) false)) - (when clear-initialiser - (&= initialiser v none)) - (rwhen (and (& immutable v) (or (not-in (& value v) (tag none)) (not-in (& initialiser v) (tag none)))) + (define (write-variable (v variable) (new-value object) (clear-initializer boolean)) object + (const coerced-value object (as new-value (&opt type v) false)) + (when clear-initializer + (&= initializer v none)) + (rwhen (and (& immutable v) (or (not-in (& value v) (tag none)) (not-in (& initializer v) (tag none)))) (throw-error -reference-error "cannot initialise a " (:character-literal "const") " variable twice")) (&= value v coerced-value) (return coerced-value)) @@ -1058,17 +1233,17 @@ (throw-error -reference-error "this access is ambiguous because it found several different instance properties in the same class")))) - (%text :comment (:global-call find-property o multiname access flat) " looks in object " (:local o) + (%text :comment (:global-call find-archetype-property o multiname access flat) " looks in object " (:local o) " for any local or inherited property with one of the names in " (:local multiname) " and access that includes " (:local access) ". If " (:local flat) " is " (:tag true) - ", then inherited properties are not considered in the search except when " (:local o) " is a class. If it finds no property, " (:global find-property) - " returns " (:tag none) ". If it finds one property, " (:global find-property) - " returns it. If it finds more than one property, " (:global find-property) " prefers the more local one in the list of " (:local o) :apostrophe - "s superobjects; if two or more properties remain, the singleton one is preferred; if two or more properties still remain, " - (:global find-property) " throws an error.") - (%text :comment "Note that " (:global-call find-property o multiname access flat) " searches " (:local o) " itself rather than " (:local o) :apostrophe - "s class for properties. " (:global find-property) " will not find instance properties unless " (:local o) " is a class.") - (define (find-property (o object) (multiname multiname) (access access) (flat boolean)) + ", then inherited properties are not considered in the search except when " (:local o) " is a class. If it finds no property, " (:global find-archetype-property) + " returns " (:tag none) ". If it finds one property, " (:global find-archetype-property) + " returns it. If it finds more than one property, " (:global find-archetype-property) " prefers the more local one in the list of " (:local o) :apostrophe + "s superclasses or archetypes; if two or more properties remain, the singleton one is preferred; if two or more properties still remain, " + (:global find-archetype-property) " throws an error.") + (%text :comment "Note that " (:global-call find-archetype-property o multiname access flat) " searches " (:local o) " itself rather than " (:local o) :apostrophe + "s class for properties. " (:global find-archetype-property) " will not find instance properties unless " (:local o) " is a class.") + (define (find-archetype-property (o object) (multiname multiname) (access access) (flat boolean)) property-opt (var m property-opt) (case o @@ -1077,17 +1252,27 @@ (:narrow (union simple-instance reg-exp date package) (<- m (find-local-singleton-property o multiname access))) (:narrow class - (<- m (find-local-singleton-property o multiname access)) - (when (in m (tag none)) - (<- m (find-local-instance-property o multiname access))))) + (<- m (find-class-property o multiname access)))) (rwhen (not-in m (tag none)) (return m)) - (rwhen (and flat (not-in o class)) + (rwhen flat (return none)) - (const super object-opt (object-super o)) - (rwhen (in super (tag none) :narrow-false) + (const a object-opt (archetype o)) + (rwhen (in a (tag none) :narrow-false) (return none)) - (return (find-property super multiname access flat))) + (return (find-archetype-property a multiname access flat))) + + + (define (find-class-property (c class) (multiname multiname) (access access)) + property-opt + (var m property-opt (find-local-singleton-property c multiname access)) + (when (in m (tag none)) + (<- m (find-local-instance-property c multiname access)) + (when (in m (tag none)) + (const super class-opt (& super c)) + (when (not-in super (tag none) :narrow-true) + (<- m (find-class-property super multiname access))))) + (return m)) (%text :comment (:global-call find-base-instance-property c multiname accesses) " looks in class " (:local c) @@ -1119,16 +1304,7 @@ (return m) (return (get-derived-instance-property (assert-not-in (& super c) (tag none)) m-base accesses)))) - - #| - ;***** Used for initialisation only - (define (lookup-instance-property (c class) (qname qualified-name) (access access)) instance-property-opt - (const m-base instance-property-opt (find-base-instance-property c (list-set qname) access)) - (rwhen (in m-base (tag none) :narrow-false) - (return none)) - (return (get-derived-instance-property c m-base access)))|# - - + (%text :comment (:global-call read-implicit-this env) " returns the value of implicit " (:character-literal "this") " to be used to access instance properties within a class" :apostrophe "s scope without using the " (:character-literal ".") " operator. An implicit " (:character-literal "this") " is well-defined only inside instance methods and constructors; " (:global read-implicit-this) @@ -1147,6 +1323,13 @@ (return this)) + (define (has-property (o object) (qname qualified-name) (flat boolean)) boolean + (const c class (object-type o)) + (return (or (not-in (find-base-instance-property c (list-set qname) read) (tag none)) + (not-in (find-base-instance-property c (list-set qname) write) (tag none)) + (not-in (find-archetype-property o (list-set qname) read flat) (tag none)) + (not-in (find-archetype-property o (list-set qname) write flat) (tag none))))) + (%heading (2 :semantics) "Reading") (%text :comment "If " (:local r) " is an " (:type object) ", " (:global-call read-reference r phase) " returns it unchanged. If " @@ -1158,7 +1341,7 @@ (:narrow object (<- result r)) (:narrow lexical-reference (<- result (lexical-read (& env r) (& variable-multiname r) phase))) (:narrow dot-reference - (<- result ((& read (& limit r)) (& base r) (& limit r) (& property-multiname r) none phase))) + (<- result ((& read (& limit r)) (& base r) (& limit r) (& multiname r) none phase))) (:narrow bracket-reference (<- result ((& bracket-read (& limit r)) (& base r) (& limit r) (& args r) phase)))) (if (not-in result (tag none) :narrow-true) @@ -1198,7 +1381,7 @@ (define (ordinary-bracket-read (o object) (limit class) (args (vector object)) (phase phase)) object-opt (rwhen (/= (length args) 1) (throw-error -argument-error "exactly one argument must be supplied")) - (const qname qualified-name (to-qualified-name (nth args 0) phase)) + (const qname qualified-name (object-to-qualified-name (nth args 0) phase)) (return ((& read limit) o limit (list-set qname) none phase))) @@ -1220,7 +1403,7 @@ (rwhen (in value (tag none) :narrow-false) (case phase (:select (tag compile) - (throw-error -constant-error "cannot read a " (:character-literal "with") " statement" :apostrophe "s frame from a constant expression")) + (throw-error -constant-error "cannot read a " (:character-literal "with") " statement" :apostrophe "s frame from constant expressions")) (:select (tag run) (throw-error -uninitialized-error "cannot read a " (:character-literal "with") " statement" :apostrophe "s frame before that statement" :apostrophe @@ -1240,7 +1423,8 @@ (return (read-instance-property o limit m-base phase))) (rwhen (/= limit (object-type o) class) (return none)) - (const m property-opt (find-property o multiname read false)) + (const flat boolean (and (not-in env (tag none)) (in o class))) + (const m property-opt (find-archetype-property o multiname read flat)) (case m (:select (tag none) (if (and (in env (tag none)) @@ -1279,11 +1463,12 @@ (const v object-opt (& value (find-slot this m))) (rwhen (in v (tag none) :narrow-false) (case phase - (:select (tag compile) (throw-error -constant-error "cannot read an uninitalised " (:character-literal "const") " variable from a constant expression")) + (:select (tag compile) (throw-error -constant-error "cannot read uninitalised " (:character-literal "const") " variables from constant expressions")) (:select (tag run) (throw-error -uninitialized-error "cannot read a " (:character-literal "const") " instance variable before it is initialised")))) (return v)) (:narrow instance-method - (return (new method-closure this m))) + (const slots (list-set slot) (list-set (new slot ivar-function-length (real-to-float64 (& length m))))) + (return (new method-closure this m slots))) (:narrow instance-getter (return ((& call m) this phase))) (:narrow instance-setter @@ -1309,23 +1494,21 @@ (:narrow object (return value)) (:select (tag none) (rwhen (not (& immutable m)) - (case phase - (:select (tag compile) (throw-error -constant-error "cannot read a mutable variable from a constant expression")) - (:select (tag run) (throw-error -uninitialized-error)))) + (throw-error -uninitialized-error)) (note "Try to run a " (:character-literal "const") " variable" :apostrophe "s initialiser if there is one.") (setup-variable m) - (const initialiser (union initialiser (tag none busy)) (& initialiser m)) - (rwhen (in initialiser (tag none busy) :narrow-false) + (const initializer (union initializer (tag none busy)) (& initializer m)) + (rwhen (in initializer (tag none busy) :narrow-false) (case phase (:select (tag compile) (throw-error -constant-error "a constant expression cannot access a constant with a missing or recursive initialiser")) (:select (tag run) (throw-error -uninitialized-error)))) - (&= initialiser m busy) + (&= initializer m busy) (var coerced-value object) - (catch ((const new-value object (initialiser (&opt initialiser-env m) compile)) + (catch ((const new-value object (initializer (&opt initializer-env m) compile)) (<- coerced-value (write-variable m new-value true))) (x) - (note "If initialisation failed, restore " (:expr (union initialiser (tag none busy)) (& initialiser m)) " to its original value so it can be tried later.") - (&= initialiser m initialiser) + (note "If initialisation failed, restore " (:expr (union initializer (tag none busy)) (& initializer m)) " to its original value so it can be tried later.") + (&= initializer m initializer) (throw x)) (return coerced-value)) (:select uninstantiated-function @@ -1353,7 +1536,7 @@ (lexical-write (& env r) (& variable-multiname r) new-value (not (& strict r)) phase) (<- result ok)) (:narrow dot-reference - (<- result ((& write (& limit r)) (& base r) (& limit r) (& property-multiname r) none true new-value phase))) + (<- result ((& write (& limit r)) (& base r) (& limit r) (& multiname r) none true new-value phase))) (:narrow bracket-reference (<- result ((& bracket-write (& limit r)) (& base r) (& limit r) (& args r) new-value phase)))) (rwhen (in result (tag none)) @@ -1384,7 +1567,7 @@ (tag none ok) (rwhen (/= (length args) 1) (throw-error -argument-error "exactly one argument must be supplied")) - (const qname qualified-name (to-qualified-name (nth args 0) phase)) + (const qname qualified-name (object-to-qualified-name (nth args 0) phase)) (return ((& write limit) o limit (list-set qname) none true new-value phase))) @@ -1431,7 +1614,7 @@ (return ok)) (rwhen (/= limit (object-type o) class) (return none)) - (const m property-opt (find-property o multiname write true)) + (const m property-opt (find-archetype-property o multiname write true)) (case m (:select (tag none) (reserve qname) @@ -1442,7 +1625,7 @@ (note "Before trying to create a new dynamic property named " (:local qname) ", check that there is no read-only fixed property with the same name.") (rwhen (and (in (find-base-instance-property (object-type o) (list-set qname) read) (tag none)) - (in (find-property o (list-set qname) read true) (tag none))) + (in (find-archetype-property o (list-set qname) read true) (tag none))) (create-dynamic-property o qname false true new-value) (return ok))) (return none)) @@ -1470,7 +1653,7 @@ (case m (:narrow instance-variable (const s slot (find-slot this m)) - (const coerced-value object (implicit-coerce new-value (&opt type m) false)) + (const coerced-value object (as new-value (&opt type m) false)) (rwhen (and (& immutable m) (not-in (& value s) (tag none))) (throw-error -reference-error "cannot initialise a " (:character-literal "const") " instance variable twice")) (&= value s coerced-value)) @@ -1512,7 +1695,7 @@ (:narrow lexical-reference (<- result (lexical-delete (& env r) (& variable-multiname r) phase))) (:narrow dot-reference - (<- result ((& delete (& limit r)) (& base r) (& limit r) (& property-multiname r) none phase))) + (<- result ((& delete (& limit r)) (& base r) (& limit r) (& multiname r) none phase))) (:narrow bracket-reference (<- result ((& bracket-delete (& limit r)) (& base r) (& limit r) (& args r) phase)))) (if (not-in result (tag none) :narrow-true) @@ -1523,7 +1706,7 @@ (define (ordinary-bracket-delete (o object) (limit class) (args (vector object)) (phase (tag run))) boolean-opt (rwhen (/= (length args) 1) (throw-error -argument-error "exactly one argument must be supplied")) - (const qname qualified-name (to-qualified-name (nth args 0) phase)) + (const qname qualified-name (object-to-qualified-name (nth args 0) phase)) (return ((& delete limit) o limit (list-set qname) none phase))) @@ -1559,7 +1742,7 @@ (return false)) (rwhen (/= limit (object-type o) class) (return none)) - (const m property-opt (find-property o multiname write true)) + (const m property-opt (find-archetype-property o multiname write true)) (case m (:select (tag none) (return none)) (:select (tag forbidden) @@ -1581,36 +1764,48 @@ (%heading (2 :semantics) "Enumerating") + (define (ordinary-enumerate (o object)) (list-set object) (const e1 (list-set object) (enumerate-instance-properties (object-type o))) - (const e2 (list-set object) (enumerate-properties o)) + (const e2 (list-set object) (enumerate-archetype-properties o)) (return (set+ e1 e2))) (define (enumerate-instance-properties (c class)) (list-set object) (var e (list-set object) (list-set-of object)) (for-each (& instance-properties c) m - (when (& enumerable m) + (when (&opt enumerable m) (<- e (set+ e (map (&opt multiname m) qname (& id qname) (= (& namespace qname) public namespace)))))) - (var super class-opt (& super c)) + (const super class-opt (& super c)) (if (in super (tag none) :narrow-false) (return e) (return (set+ e (enumerate-instance-properties super))))) - (define (enumerate-properties (o object)) (list-set object) + (define (enumerate-archetype-properties (o object)) (list-set object) (var e (list-set object) (list-set-of object)) - (for-each (set+ (list-set o) (object-supers o)) s - (when (in s binding-object :narrow-true) - (for-each (& local-bindings s) b - (when (and (& enumerable b) (= (& namespace (& qname b)) public namespace)) - (<- e (set+ e (list-set-of object (& id (& qname b))))))))) + (for-each (set+ (list-set o) (archetypes o)) a + (when (in a binding-object :narrow-true) + (<- e (set+ e (enumerate-singleton-properties a))))) (return e)) + (define (enumerate-singleton-properties (o binding-object)) (list-set object) + (var e (list-set object) (list-set-of object)) + (for-each (& local-bindings o) b + (when (and (& enumerable b) (= (& namespace (& qname b)) public namespace)) + (<- e (set+ e (list-set-of object (& id (& qname b))))))) + (when (in o class :narrow-true) + (const super class-opt (& super o)) + (when (not-in super (tag none) :narrow-true) + (<- e (set+ e (enumerate-singleton-properties super))))) + (return e)) + + + (%heading (2 :semantics) "Creating Instances") (define (create-simple-instance (c class) - (super object-opt) + (archetype object-opt) (call (union (-> (object simple-instance (vector object) phase) object) (tag none))) (construct (union (-> (simple-instance (vector object) phase) object) (tag none))) (env environment-opt)) @@ -1621,7 +1816,7 @@ (when (in m instance-variable :narrow-true) (const slot slot (new slot m (&opt default-value m))) (<- slots (set+ slots (list-set slot)))))) - (return (new simple-instance (list-set-of local-binding) super (not (& dynamic c)) c slots call construct env))) + (return (new simple-instance (list-set-of local-binding) archetype (not (& dynamic c)) c slots call construct env))) @@ -1743,7 +1938,8 @@ (var m-overridden instance-property-opt none) (when (not-in m-base (tag none) :narrow-true) (<- m-overridden (get-derived-instance-property c m-base accesses)) - (<- defined-multiname (&opt multiname (assert-not-in m-overridden (tag none)))) + (quiet-assert (not-in m-overridden (tag none) :narrow-true)) + (<- defined-multiname (&opt multiname m-overridden)) (rwhen (not (set<= requested-multiname defined-multiname multiname)) (throw-error -definition-error "cannot extend the set of a property" :apostrophe "s namespaces when overriding it")) (var good-kind boolean) @@ -1756,7 +1952,7 @@ (throw-error -definition-error "a method can override only another method, a variable can override only another variable, a getter can override only a getter or a variable, and " "a setter can override only a setter or a variable")) - (rwhen (& final (assert-not-in m-overridden (tag none))) + (rwhen (& final m-overridden) (throw-error -definition-error "cannot override a " (:character-literal "final") " property"))) (rwhen (some (& instance-properties c) m2 (and (nonempty (set* (&opt multiname m2) defined-multiname)) (accesses-overlap (instance-property-accesses m2) accesses))) (throw-error -definition-error "duplicate definition in the same scope")) @@ -1819,7 +2015,7 @@ (var value variable-value (& value m)) (when (in value uninstantiated-function :narrow-true) (<- value (instantiate-function value env) :end-narrow)) - (return (new variable (&opt type m) value (& immutable m) none (& initialiser m) env))) + (return (new variable (&opt type m) value (& immutable m) none (& initializer m) env))) (:narrow dynamic-var (var value (union object uninstantiated-function) (& value m)) (when (in value uninstantiated-function :narrow-true) @@ -1887,6 +2083,62 @@ + (%heading (2 :semantics) "Sealing") + + (define (seal-object (o object)) void + (when (in o (union simple-instance reg-exp date package) :narrow-true) + (&= sealed o true))) + + + (define (seal-all-local-properties (o object)) void + (when (in o binding-object :narrow-true) + (for-each (& local-bindings o) b + (const m singleton-property (& content b)) + (when (in m dynamic-var :narrow-true) + (&= sealed m true))))) + + + (define (seal-local-property (o object) (qname qualified-name)) void + (const c class (object-type o)) + (when (and (in (find-base-instance-property c (list-set qname) read) (tag none)) + (in (find-base-instance-property c (list-set qname) write) (tag none)) + (in o binding-object :narrow-true)) + (const matching-properties (list-set singleton-property) (map (& local-bindings o) b (& content b) (= (& qname b) qname qualified-name))) + (for-each matching-properties m + (when (in m dynamic-var :narrow-true) + (&= sealed m true))))) + + + + (%heading (2 :semantics) "Standard Class Utilities") + + (define (default-arg (args (vector object)) (n integer) (default object)) object + (if (< n (length args)) + (return (nth args n)) + (return default))) + + + (define (std-const-binding (qname qualified-name) (type (delay class)) (value object)) local-binding + (return (new local-binding + qname read-write false false + (new variable type value true none none :uninit)))) + + + (define (std-explicit-const-binding (qname qualified-name) (type (delay class)) (value object)) local-binding + (return (new local-binding + qname read-write true false + (new variable type value true none none :uninit)))) + + + (define (std-function (qname qualified-name) (call (-> (object simple-instance (vector object) phase) object)) (length integer)) local-binding + (const slots (list-set slot) (list-set (new slot ivar-function-length (real-to-float64 length)))) + (const f simple-instance (new simple-instance (list-set-of local-binding) (delay -function-prototype) true -function slots call none none)) + (return (new local-binding + qname read-write false false + (new variable -function f true none none :uninit)))) + + + (%heading 1 "Expressions") (grammar-argument :beta allow-in no-in) @@ -1911,8 +2163,7 @@ (production :identifier ($identifier) identifier-identifier (name (name $identifier))) (production :identifier (get) identifier-get (name "get")) (production :identifier (set) identifier-set (name "set")) - (production :identifier (exclude) identifier-exclude (name "exclude")) - (production :identifier (include) identifier-include (name "include"))) + (? js2 (production :identifier (include) identifier-include (name "include")))) (%print-actions) (%heading 2 "Qualified Identifiers") @@ -2189,17 +2440,17 @@ (production :field-name ($string) field-name-string ((validate cxt env) :forward) ((setup) :forward) - ((eval (env :unused) phase) (return (list-set (to-qualified-name (value $string) phase))))) + ((eval (env :unused) phase) (return (list-set (object-to-qualified-name (value $string) phase))))) (production :field-name ($number) field-name-number ((validate cxt env) :forward) ((setup) :forward) - ((eval (env :unused) phase) (return (list-set (to-qualified-name (value $number) phase))))) + ((eval (env :unused) phase) (return (list-set (object-to-qualified-name (value $number) phase))))) (production :field-name (:paren-expression) field-name-paren-expression ((validate cxt env) :forward) ((setup) :forward) ((eval env phase) (const a object (read-reference ((eval :paren-expression) env phase) phase)) - (return (list-set (to-qualified-name a phase)))))) + (return (list-set (object-to-qualified-name a phase)))))) (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval)) @@ -2302,7 +2553,7 @@ (const limit class-opt (& super c)) (assert (not-in limit (tag none) :narrow-true) (:action validate) " ensured that " (:local limit) " cannot be " (:tag none) " at this point.") - (const coerced object (implicit-coerce o limit false)) + (const coerced object (as o limit false)) (rwhen (in coerced (tag null)) (return null)) (return (new limited-instance coerced limit))) @@ -2410,7 +2661,7 @@ ((setup) :forward) ((eval env phase) (rwhen (in phase (tag compile) :narrow-false) - (throw-error -constant-error (:character-literal "++") " cannot be used in a constant expression")) + (throw-error -constant-error (:character-literal "++") " cannot be used in constant expressions")) (const r obj-or-ref ((eval :postfix-expression) env phase)) (const a object (read-reference r phase)) (const b object (plus a phase)) @@ -2422,7 +2673,7 @@ ((setup) :forward) ((eval env phase) (rwhen (in phase (tag compile) :narrow-false) - (throw-error -constant-error (:character-literal "--") " cannot be used in a constant expression")) + (throw-error -constant-error (:character-literal "--") " cannot be used in constant expressions")) (const r obj-or-ref ((eval :postfix-expression) env phase)) (const a object (read-reference r phase)) (const b object (plus a phase)) @@ -2528,7 +2779,7 @@ (%heading 2 "Property Operators") (rule :property-operator ((validate (-> (context environment) void)) (setup (-> () void)) - (eval (-> (environment obj-optional-limit phase) obj-or-ref))) + (eval (-> (environment obj-optional-limit phase) obj-or-ref))) (production :property-operator (\. :qualified-identifier) property-operator-qualified-identifier ((validate cxt env) :forward) ((setup) :forward) @@ -2632,7 +2883,7 @@ ((setup) :forward) ((eval env phase) (rwhen (in phase (tag compile) :narrow-false) - (throw-error -constant-error (:character-literal "delete") " cannot be used in a constant expression")) + (throw-error -constant-error (:character-literal "delete") " cannot be used in constant expressions")) (const r obj-or-ref ((eval :postfix-expression) env phase)) (return (delete-reference r (strict :unary-expression 0) phase)))) (production :unary-expression (void :unary-expression) unary-expression-void @@ -2653,7 +2904,7 @@ ((setup) :forward) ((eval env phase) (rwhen (in phase (tag compile) :narrow-false) - (throw-error -constant-error (:character-literal "++") " cannot be used in a constant expression")) + (throw-error -constant-error (:character-literal "++") " cannot be used in constant expressions")) (const r obj-or-ref ((eval :postfix-expression) env phase)) (const a object (read-reference r phase)) (const b object (plus a phase)) @@ -2665,7 +2916,7 @@ ((setup) :forward) ((eval env phase) (rwhen (in phase (tag compile) :narrow-false) - (throw-error -constant-error (:character-literal "--") " cannot be used in a constant expression")) + (throw-error -constant-error (:character-literal "--") " cannot be used in constant expressions")) (const r obj-or-ref ((eval :postfix-expression) env phase)) (const a object (read-reference r phase)) (const b object (plus a phase)) @@ -2707,12 +2958,12 @@ (%text :comment (:global-call plus a phase) " returns the value of the unary expression " (:character-literal "+") (:local a) ". If " (:local phase) " is " (:tag compile) ", only constant operations are permitted.") (define (plus (a object) (phase phase)) object - (return (to-general-number a phase))) + (return (object-to-general-number a phase))) (%text :comment (:global-call minus a phase) " returns the value of the unary expression " (:character-literal "-") (:local a) ". If " (:local phase) " is " (:tag compile) ", only constant operations are permitted.") (define (minus (a object) (phase phase)) object - (const x general-number (to-general-number a phase)) + (const x general-number (object-to-general-number a phase)) (return (general-number-negate x))) (define (general-number-negate (x general-number)) general-number @@ -2723,7 +2974,7 @@ (:narrow float64 (return (float64-negate x))))) (define (bit-not (a object) (phase phase)) object - (const x general-number (to-general-number a phase)) + (const x general-number (object-to-general-number a phase)) (case x (:narrow long (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (& value x)) @@ -2737,8 +2988,8 @@ (%text :comment (:global-call logical-not a phase) " returns the value of the unary expression " (:character-literal "!") (:local a) ". If " (:local phase) " is " (:tag compile) ", only constant operations are permitted.") - (define (logical-not (a object) (phase phase)) object - (return (not (to-boolean a phase)))) + (define (logical-not (a object) (phase phase :unused)) object + (return (not (object-to-boolean a)))) (%heading 2 "Multiplicative Operators") @@ -2772,8 +3023,8 @@ (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval)) (define (multiply (a object) (b object) (phase phase)) object - (const x general-number (to-general-number a phase)) - (const y general-number (to-general-number b phase)) + (const x general-number (object-to-general-number a phase)) + (const y general-number (object-to-general-number b phase)) (when (or (in x (union long u-long)) (in y (union long u-long))) (const i integer-opt (check-integer x)) (const j integer-opt (check-integer y)) @@ -2785,8 +3036,8 @@ (return (float64-multiply (to-float64 x) (to-float64 y)))) (define (divide (a object) (b object) (phase phase)) object - (const x general-number (to-general-number a phase)) - (const y general-number (to-general-number b phase)) + (const x general-number (object-to-general-number a phase)) + (const y general-number (object-to-general-number b phase)) (when (or (in x (union long u-long)) (in y (union long u-long))) (const i integer-opt (check-integer x)) (const j integer-opt (check-integer y)) @@ -2798,8 +3049,8 @@ (return (float64-divide (to-float64 x) (to-float64 y)))) (define (remainder (a object) (b object) (phase phase)) object - (const x general-number (to-general-number a phase)) - (const y general-number (to-general-number b phase)) + (const x general-number (object-to-general-number a phase)) + (const y general-number (object-to-general-number b phase)) (when (or (in x (union long u-long)) (in y (union long u-long))) (const i integer-opt (check-integer x)) (const j integer-opt (check-integer y)) @@ -2837,12 +3088,12 @@ (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval)) (define (add (a object) (b object) (phase phase)) object - (const ap primitive-object (to-primitive a null phase)) - (const bp primitive-object (to-primitive b null phase)) + (const ap primitive-object (object-to-primitive a none phase)) + (const bp primitive-object (object-to-primitive b none phase)) (rwhen (or (in ap (union char16 string)) (in bp (union char16 string))) - (return (append (to-string ap phase) (to-string bp phase)))) - (const x general-number (to-general-number ap phase)) - (const y general-number (to-general-number bp phase)) + (return (append (object-to-string ap phase) (object-to-string bp phase)))) + (const x general-number (object-to-general-number ap phase)) + (const y general-number (object-to-general-number bp phase)) (when (or (in x (union long u-long)) (in y (union long u-long))) (const i integer-opt (check-integer x)) (const j integer-opt (check-integer y)) @@ -2854,8 +3105,8 @@ (return (float64-add (to-float64 x) (to-float64 y)))) (define (subtract (a object) (b object) (phase phase)) object - (const x general-number (to-general-number a phase)) - (const y general-number (to-general-number b phase)) + (const x general-number (object-to-general-number a phase)) + (const y general-number (object-to-general-number b phase)) (when (or (in x (union long u-long)) (in y (union long u-long))) (const i integer-opt (check-integer x)) (const j integer-opt (check-integer y)) @@ -2898,8 +3149,8 @@ (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval)) (define (shift-left (a object) (b object) (phase phase)) object - (const x general-number (to-general-number a phase)) - (var count integer (truncate-to-integer (to-general-number b phase))) + (const x general-number (object-to-general-number a phase)) + (var count integer (truncate-to-integer (object-to-general-number b phase))) (case x (:narrow (union float32 float64) (var i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x))) @@ -2916,8 +3167,8 @@ (return (new u-long i))))) (define (shift-right (a object) (b object) (phase phase)) object - (const x general-number (to-general-number a phase)) - (var count integer (truncate-to-integer (to-general-number b phase))) + (const x general-number (object-to-general-number a phase)) + (var count integer (truncate-to-integer (object-to-general-number b phase))) (case x (:narrow (union float32 float64) (var i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x))) @@ -2934,8 +3185,8 @@ (return (new u-long (unsigned-wrap64 i)))))) (define (shift-right-unsigned (a object) (b object) (phase phase)) object - (const x general-number (to-general-number a phase)) - (var count integer (truncate-to-integer (to-general-number b phase))) + (const x general-number (object-to-general-number a phase)) + (var count integer (truncate-to-integer (object-to-general-number b phase))) (case x (:narrow (union float32 float64) (var i (integer-range 0 (- (expt 2 32) 1)) (unsigned-wrap32 (truncate-to-integer x))) @@ -2993,7 +3244,7 @@ ((eval env phase) (const a object (read-reference ((eval :relational-expression) env phase) phase)) (const b object (read-reference ((eval :shift-expression) env phase) phase)) - (const c class (to-class b)) + (const c class (object-to-class b)) (return (is a c)))) (production (:relational-expression :beta) ((:relational-expression :beta) as :shift-expression) relational-expression-as ((validate cxt env) :forward) @@ -3001,20 +3252,16 @@ ((eval env phase) (const a object (read-reference ((eval :relational-expression) env phase) phase)) (const b object (read-reference ((eval :shift-expression) env phase) phase)) - (const c class (to-class b)) - (return (implicit-coerce a c true)))) + (const c class (object-to-class b)) + (return (as a c true)))) (production (:relational-expression allow-in) ((:relational-expression allow-in) in :shift-expression) relational-expression-in ((validate cxt env) :forward) ((setup) :forward) ((eval env phase) (const a object (read-reference ((eval :relational-expression) env phase) phase)) (const b object (read-reference ((eval :shift-expression) env phase) phase)) - (const qname qualified-name (to-qualified-name a phase)) - (const c class (object-type b)) - (return (or (not-in (find-base-instance-property c (list-set qname) read) (tag none)) - (not-in (find-base-instance-property c (list-set qname) write) (tag none)) - (not-in (find-property b (list-set qname) read false) (tag none)) - (not-in (find-property b (list-set qname) write false) (tag none)))))) + (const qname qualified-name (object-to-qualified-name a phase)) + (return (has-property b qname false)))) (production (:relational-expression :beta) ((:relational-expression :beta) instanceof :shift-expression) relational-expression-instanceof ((validate cxt env) :forward) ((setup) :forward) @@ -3026,24 +3273,24 @@ (return (is a b))) ((is b -prototype-function) (const prototype object (dot-read b (list-set (new qualified-name public "prototype")) phase)) - (return (set-in prototype (object-supers a)))) + (return (set-in prototype (archetypes a)))) (nil (throw-error -type-error)))))) (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval)) (define (is-less (a object) (b object) (phase phase)) boolean - (const ap primitive-object (to-primitive a null phase)) - (const bp primitive-object (to-primitive b null phase)) + (const ap primitive-object (object-to-primitive a hint-number phase)) + (const bp primitive-object (object-to-primitive b hint-number phase)) (rwhen (and (in ap (union char16 string) :narrow-true) (in bp (union char16 string) :narrow-true)) - (return (< (to-string ap phase) (to-string bp phase) string))) - (return (= (general-number-compare (to-general-number ap phase) (to-general-number bp phase)) less order))) + (return (< (to-string ap) (to-string bp) string))) + (return (= (general-number-compare (object-to-general-number ap phase) (object-to-general-number bp phase)) less order))) (define (is-less-or-equal (a object) (b object) (phase phase)) boolean - (const ap primitive-object (to-primitive a null phase)) - (const bp primitive-object (to-primitive b null phase)) + (const ap primitive-object (object-to-primitive a hint-number phase)) + (const bp primitive-object (object-to-primitive b hint-number phase)) (rwhen (and (in ap (union char16 string) :narrow-true) (in bp (union char16 string) :narrow-true)) - (return (<= (to-string ap phase) (to-string bp phase) string))) - (return (in (general-number-compare (to-general-number ap phase) (to-general-number bp phase)) (tag less equal)))) + (return (<= (to-string ap) (to-string bp) string))) + (return (in (general-number-compare (object-to-general-number ap phase) (object-to-general-number bp phase)) (tag less equal)))) (%heading 2 "Equality Operators") @@ -3090,24 +3337,24 @@ (:narrow boolean (if (in b boolean :narrow-true) (return (= a b boolean)) - (return (is-equal (to-general-number a phase) b phase)))) + (return (is-equal (object-to-general-number a phase) b phase)))) (:narrow general-number - (const bp primitive-object (to-primitive b null phase)) + (const bp primitive-object (object-to-primitive b none phase)) (case bp (:select (union undefined null) (return false)) - (:select (union boolean general-number char16 string) (return (= (general-number-compare a (to-general-number bp phase)) equal order))))) + (:select (union boolean general-number char16 string) (return (= (general-number-compare a (object-to-general-number bp phase)) equal order))))) (:narrow (union char16 string) - (const bp primitive-object (to-primitive b null phase)) + (const bp primitive-object (object-to-primitive b none phase)) (case bp (:select (union undefined null) (return false)) - (:select (union boolean general-number) (return (= (general-number-compare (to-general-number a phase) (to-general-number bp phase)) equal order))) - (:narrow (union char16 string) (return (= (to-string a phase) (to-string bp phase) string))))) + (:select (union boolean general-number) (return (= (general-number-compare (object-to-general-number a phase) (object-to-general-number bp phase)) equal order))) + (:narrow (union char16 string) (return (= (to-string a) (to-string bp) string))))) (:select (union namespace compound-attribute class method-closure simple-instance date reg-exp package) (case b (:select (union undefined null) (return false)) (:select (union namespace compound-attribute class method-closure simple-instance date reg-exp package) (return (is-strictly-equal a b phase))) (:select (union boolean general-number char16 string) - (const ap primitive-object (to-primitive a null phase)) + (const ap primitive-object (object-to-primitive a none phase)) (return (is-equal ap b phase))))))) (define (is-strictly-equal (a object) (b object) (phase phase :unused)) boolean @@ -3163,8 +3410,8 @@ (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval)) (define (bit-and (a object) (b object) (phase phase)) general-number - (const x general-number (to-general-number a phase)) - (const y general-number (to-general-number b phase)) + (const x general-number (object-to-general-number a phase)) + (const y general-number (object-to-general-number b phase)) (cond ((or (in x (union long u-long) :narrow-false) (in y (union long u-long) :narrow-false)) (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer x))) @@ -3179,8 +3426,8 @@ (return (real-to-float64 (bitwise-and i j)))))) (define (bit-xor (a object) (b object) (phase phase)) general-number - (const x general-number (to-general-number a phase)) - (const y general-number (to-general-number b phase)) + (const x general-number (object-to-general-number a phase)) + (const y general-number (object-to-general-number b phase)) (cond ((or (in x (union long u-long) :narrow-false) (in y (union long u-long) :narrow-false)) (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer x))) @@ -3195,8 +3442,8 @@ (return (real-to-float64 (bitwise-xor i j)))))) (define (bit-or (a object) (b object) (phase phase)) general-number - (const x general-number (to-general-number a phase)) - (const y general-number (to-general-number b phase)) + (const x general-number (object-to-general-number a phase)) + (const y general-number (object-to-general-number b phase)) (cond ((or (in x (union long u-long) :narrow-false) (in y (union long u-long) :narrow-false)) (const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer x))) @@ -3223,7 +3470,7 @@ ((setup) :forward) ((eval env phase) (const a object (read-reference ((eval :logical-and-expression) env phase) phase)) - (if (to-boolean a phase) + (if (object-to-boolean a) (return (read-reference ((eval :bitwise-or-expression) env phase) phase)) (return a))))) @@ -3239,8 +3486,8 @@ ((eval env phase) (const a object (read-reference ((eval :logical-xor-expression) env phase) phase)) (const b object (read-reference ((eval :logical-and-expression) env phase) phase)) - (const ba boolean (to-boolean a phase)) - (const bb boolean (to-boolean b phase)) + (const ba boolean (object-to-boolean a)) + (const bb boolean (object-to-boolean b)) (return (xor ba bb))))) (rule (:logical-or-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void)) @@ -3254,7 +3501,7 @@ ((setup) :forward) ((eval env phase) (const a object (read-reference ((eval :logical-or-expression) env phase) phase)) - (if (to-boolean a phase) + (if (object-to-boolean a) (return a) (return (read-reference ((eval :logical-xor-expression) env phase) phase)))))) (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval)) @@ -3272,7 +3519,7 @@ ((setup) :forward) ((eval env phase) (const a object (read-reference ((eval :logical-or-expression) env phase) phase)) - (if (to-boolean a phase) + (if (object-to-boolean a) (return (read-reference ((eval :assignment-expression 1) env phase) phase)) (return (read-reference ((eval :assignment-expression 2) env phase) phase)))))) @@ -3287,7 +3534,7 @@ ((setup) :forward) ((eval env phase) (const a object (read-reference ((eval :logical-or-expression) env phase) phase)) - (if (to-boolean a phase) + (if (object-to-boolean a) (return (read-reference ((eval :non-assignment-expression 1) env phase) phase)) (return (read-reference ((eval :non-assignment-expression 2) env phase) phase)))))) (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval)) @@ -3309,7 +3556,7 @@ ((setup :assignment-expression))) ((eval env phase) (rwhen (in phase (tag compile) :narrow-false) - (throw-error -constant-error "assignment cannot be used in a constant expression")) + (throw-error -constant-error "assignment cannot be used in constant expressions")) (const ra obj-or-ref ((eval :postfix-expression) env phase)) (const b object (read-reference ((eval :assignment-expression) env phase) phase)) (write-reference ra b phase) @@ -3323,7 +3570,7 @@ ((setup :assignment-expression))) ((eval env phase) (rwhen (in phase (tag compile) :narrow-false) - (throw-error -constant-error "assignment cannot be used in a constant expression")) + (throw-error -constant-error "assignment cannot be used in constant expressions")) (const r-left obj-or-ref ((eval :postfix-expression) env phase)) (const o-left object (read-reference r-left phase)) (const o-right object (read-reference ((eval :assignment-expression) env phase) phase)) @@ -3339,17 +3586,17 @@ ((setup :assignment-expression))) ((eval env phase) (rwhen (in phase (tag compile) :narrow-false) - (throw-error -constant-error "assignment cannot be used in a constant expression")) + (throw-error -constant-error "assignment cannot be used in constant expressions")) (const r-left obj-or-ref ((eval :postfix-expression) env phase)) (const o-left object (read-reference r-left phase)) - (const b-left boolean (to-boolean o-left phase)) + (const b-left boolean (object-to-boolean o-left)) (var result object o-left) (case (operator :logical-assignment) (:select (tag and-eq) (when b-left (<- result (read-reference ((eval :assignment-expression) env phase) phase)))) (:select (tag xor-eq) - (const b-right boolean (to-boolean (read-reference ((eval :assignment-expression) env phase) phase) phase)) + (const b-right boolean (object-to-boolean (read-reference ((eval :assignment-expression) env phase) phase))) (<- result (xor b-left b-right))) (:select (tag or-eq) (when (not b-left) @@ -3413,7 +3660,7 @@ ((setup-and-eval env) ((setup :non-assignment-expression)) (const o object (read-reference ((eval :non-assignment-expression) env compile) compile)) - (return (to-class o))))) + (return (object-to-class o))))) (%print-actions ("Validation" validate) ("Setup and Evaluation" setup-and-eval)) @@ -3670,7 +3917,7 @@ ((setup) :forward) ((eval env d) (const o object (read-reference ((eval :paren-list-expression) env run) run)) - (if (to-boolean o run) + (if (object-to-boolean o) (return ((eval :substatement) env d)) (return d)))) (production (:if-statement full) (if :paren-list-expression (:substatement full)) if-statement-if-then-full @@ -3680,7 +3927,7 @@ ((setup) :forward) ((eval env d) (const o object (read-reference ((eval :paren-list-expression) env run) run)) - (if (to-boolean o run) + (if (object-to-boolean o) (return ((eval :substatement) env d)) (return d)))) (production (:if-statement :omega) (if :paren-list-expression (:substatement no-short-if) else (:substatement :omega)) @@ -3692,7 +3939,7 @@ ((setup) :forward) ((eval env d) (const o object (read-reference ((eval :paren-list-expression) env run) run)) - (if (to-boolean o run) + (if (object-to-boolean o) (return ((eval :substatement 1) env d)) (return ((eval :substatement 2) env d)))))) (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval)) @@ -3846,7 +4093,7 @@ (<- d1 (& value x)) (throw x))) (const o object (read-reference ((eval :paren-list-expression) env run) run)) - (rwhen (not (to-boolean o run)) + (rwhen (not (object-to-boolean o)) (return d1)))) (x) (if (and (in x break :narrow-true) (= (& label x) default label)) (return (& value x)) @@ -3871,7 +4118,7 @@ ((setup) :forward) ((eval env d) (catch ((var d1 object d) - (while (to-boolean (read-reference ((eval :paren-list-expression) env run) run) run) + (while (object-to-boolean (read-reference ((eval :paren-list-expression) env run) run)) (catch ((<- d1 ((eval :substatement) env d1))) (x) (if (and (in x continue :narrow-true) (set-in (& label x) (labels :while-statement 0))) (<- d1 (& value x)) @@ -3889,7 +4136,7 @@ (validate (-> (context environment (list-set label) jump-targets) void)) (setup (-> () void)) (eval (-> (environment object) object))) - (production (:for-statement :omega) (for \( :for-initialiser \; :optional-expression \; :optional-expression \) + (production (:for-statement :omega) (for \( :for-initializer \; :optional-expression \; :optional-expression \) (:substatement :omega)) for-statement-c-style ((validate cxt env sl jt) (const continue-labels (list-set label) (set+ sl (list-set-of label default))) @@ -3900,7 +4147,7 @@ (const compile-local-frame local-frame (new local-frame (list-set-of local-binding))) (action<- (compile-local-frame :for-statement 0) compile-local-frame) (const compile-env environment (cons compile-local-frame env)) - ((validate :for-initialiser) cxt compile-env) + ((validate :for-initializer) cxt compile-env) ((validate :optional-expression 1) cxt compile-env) ((validate :optional-expression 2) cxt compile-env) ((validate :substatement) cxt compile-env (list-set-of label) jt2)) @@ -3908,9 +4155,9 @@ ((eval env d) (const runtime-local-frame local-frame (instantiate-local-frame (compile-local-frame :for-statement 0) env)) (const runtime-env environment (cons runtime-local-frame env)) - (catch (((eval :for-initialiser) runtime-env) + (catch (((eval :for-initializer) runtime-env) (var d1 object d) - (while (to-boolean (read-reference ((eval :optional-expression 1) runtime-env run) run) run) + (while (object-to-boolean (read-reference ((eval :optional-expression 1) runtime-env run) run)) (catch ((<- d1 ((eval :substatement) runtime-env d1))) (x) (if (and (in x continue :narrow-true) (set-in (& label x) (labels :for-statement 0))) (<- d1 (& value x)) @@ -3964,35 +4211,35 @@ (throw x)))))) - (rule :for-initialiser ((enabled (writable-cell boolean)) + (rule :for-initializer ((enabled (writable-cell boolean)) (validate (-> (context environment) void)) (setup (-> () void)) (eval (-> (environment) void))) - (production :for-initialiser () for-initialiser-empty + (production :for-initializer () for-initializer-empty ((validate (cxt :unused) (env :unused))) ((setup)) ((eval (env :unused)))) - (production :for-initialiser ((:list-expression no-in)) for-initialiser-expression + (production :for-initializer ((:list-expression no-in)) for-initializer-expression ((validate cxt env) ((validate :list-expression) cxt env)) ((setup) ((setup :list-expression))) ((eval env) (exec (read-reference ((eval :list-expression) env run) run)))) - (production :for-initialiser ((:variable-definition no-in)) for-initialiser-variable-definition + (production :for-initializer ((:variable-definition no-in)) for-initializer-variable-definition ((validate cxt env) ((validate :variable-definition) cxt env none)) ((setup) ((setup :variable-definition))) ((eval env) (exec ((eval :variable-definition) env undefined)))) - (production :for-initialiser (:attributes :no-line-break (:variable-definition no-in)) for-initialiser-attribute-variable-definition + (production :for-initializer (:attributes :no-line-break (:variable-definition no-in)) for-initializer-attribute-variable-definition ((validate cxt env) ((validate :attributes) cxt env) ((setup :attributes)) (const attr attribute ((eval :attributes) env compile)) - (action<- (enabled :for-initialiser 0) (not-in attr false-type)) + (action<- (enabled :for-initializer 0) (not-in attr false-type)) (when (not-in attr false-type :narrow-true) ((validate :variable-definition) cxt env attr))) ((setup) - (when (enabled :for-initialiser 0) + (when (enabled :for-initializer 0) ((setup :variable-definition)))) ((eval env) - (when (enabled :for-initialiser 0) + (when (enabled :for-initializer 0) (exec ((eval :variable-definition) env undefined)))))) @@ -4301,13 +4548,6 @@ (return ((eval :directives) env d)) (return d)))) (? js2 - (production (:directive :omega_2) (:package-definition) directive-package-definition - ((validate (cxt :unused) (env :unused) (jt :unused) (preinst :unused) attr) - (if (in attr (tag none true)) - (todo) - (throw-error -attribute-error "a " (:character-literal "package") " definition only permits the attributes " (:character-literal "true") " and " (:character-literal "false")))) - ((setup) (todo)) - ((eval (env :unused) (d :unused)) (todo))) (production (:directive :omega_2) (:include-directive (:semicolon :omega_2)) directive-include-directive ((validate (cxt :unused) (env :unused) (jt :unused) (preinst :unused) attr) (if (in attr (tag none true)) @@ -4346,11 +4586,11 @@ ; ((validate (cxt :unused) (env :unused) (preinst :unused) (attr :unused)) (todo)) ; ((setup) (todo)) ; ((eval (env :unused) (d :unused)) (todo))) + (production (:annotatable-directive :omega_2) (:import-directive (:semicolon :omega_2)) annotatable-directive-import-directive + ((validate cxt env preinst attr) ((validate :import-directive) cxt env preinst attr)) + ((setup)) + ((eval (env :unused) d) (return d))) (? js2 - (production (:annotatable-directive :omega_2) (:import-directive (:semicolon :omega_2)) annotatable-directive-import-directive - ((validate (cxt :unused) (env :unused) (preinst :unused) (attr :unused)) (todo)) - ((setup) (todo)) - ((eval (env :unused) (d :unused)) (todo))) (production (:annotatable-directive :omega_2) (:export-definition (:semicolon :omega_2)) annotatable-directive-export-definition ((validate (cxt :unused) (env :unused) (preinst :unused) (attr :unused)) (todo)) ((setup) (todo)) @@ -4359,7 +4599,8 @@ ((validate cxt env (preinst :unused) attr) (if (in attr (tag none true)) ((validate :use-directive) cxt env) - (throw-error -attribute-error "a " (:character-literal "use") " directive only permits the attributes " (:character-literal "true") " and " (:character-literal "false")))) + (throw-error -attribute-error + "a " (:character-literal "use") " directive only permits the attributes " (:character-literal "true") " and " (:character-literal "false")))) ((setup)) ((eval (env :unused) d) (return d)))) @@ -4425,7 +4666,7 @@ ((setup) ((setup :attribute-expression))) ((eval env phase) (const a object (read-reference ((eval :attribute-expression) env phase) phase)) - (return (to-attribute a phase)))) + (return (object-to-attribute a phase)))) (production :attribute (true) attribute-true ((validate cxt env) :forward) ((setup)) @@ -4458,17 +4699,77 @@ (%print-actions ("Validation" validate)) - (? js2 + (%heading 2 "Import Directive") + (rule :import-directive ((validate (-> (context environment boolean attribute-opt-not-false) void))) + (production :import-directive (import :package-name) import-directive-unnamed + ((validate (cxt :unused) env preinst attr) + (rwhen (not preinst) + (throw-error -syntax-error "a package may be imported only in a preinstantiated scope")) + (const frame frame (nth env 0)) + (rwhen (not-in frame package :narrow-false) + (throw-error -syntax-error "a package may be imported only into a package scope")) + (rwhen (not-in attr (tag none true)) + (throw-error -attribute-error + "an unnamed " (:character-literal "import") " directive only permits the attributes " (:character-literal "true") " and " (:character-literal "false"))) + (const pkg-name string (name :package-name)) + (const pkg package (locate-package pkg-name)) + (import-package-into pkg frame))) + (production :import-directive (import :identifier = :package-name) import-directive-named + ((validate (cxt :unused) env preinst attr) + (rwhen (not preinst) + (throw-error -syntax-error "a package may be imported only in a preinstantiated scope")) + (const frame frame (nth env 0)) + (rwhen (not-in frame package :narrow-false) + (throw-error -syntax-error "a package may be imported only into a package scope")) + (const a compound-attribute (to-compound-attribute attr)) + (rwhen (& dynamic a) + (throw-error -attribute-error "a package definition cannot have the " (:character-literal "dynamic") " attribute")) + (rwhen (& prototype a) + (throw-error -attribute-error "a package definition cannot have the " (:character-literal "prototype") " attribute")) + (const pkg-name string (name :package-name)) + (const pkg package (locate-package pkg-name)) + (const v variable (new variable -package pkg true none none :uninit)) + (exec (define-singleton-property env (name :identifier) (& namespaces a) (& override-mod a) (& explicit a) read-write v)) + (import-package-into pkg frame)))) + (%print-actions ("Validation" validate)) + + + (define (locate-package (name string)) package + (/* "Look for a package bound to " (:local name) " in the implementation" :apostrophe "s list of available packages. " + "If one is found, let " (:local pkg) ":" :nbsp (:type package) " be that package; otherwise, throw an implementation-defined error.") + (var pkg (union package (tag none)) none) + (reserve pkg2) + (when (some package-database pkg2 (= (& name pkg2) name string) :define-true) + (<- pkg pkg2)) + (rwhen (in pkg (tag none) :narrow-false) + (throw-error -error "package not found")) + (*/) + (const initialize (union (-> () void) (tag none busy)) (& initialize pkg)) + (case initialize + (:select (tag none)) + (:select (tag busy) (throw-error -uninitialized-error "circular package dependency")) + (:narrow (-> () void) + (initialize) + (assert (in (& initialize pkg) (tag none))))) + (return pkg)) + + + (define (import-package-into (source package) (destination package)) void + (for-each (& local-bindings source) b + (when (not (or (& explicit b) + (in (& content b) (tag forbidden)) + (some (& local-bindings destination) d (and (= (& qname b) (& qname d) qualified-name) (accesses-overlap (& accesses b) (& accesses d)))))) + (&= local-bindings destination (set+ (& local-bindings destination) (list-set b)))))) + + + #| (%heading 2 "Import Directive") (production :import-directive (import :import-binding :includes-excludes) import-directive-import) (production :import-directive (import :import-binding \, namespace :paren-list-expression :includes-excludes) import-directive-import-namespaces) - (production :import-binding (:import-source) import-binding-import-source) - (production :import-binding (:identifier = :import-source) import-binding-named-import-source) - - (production :import-source ($string) import-source-string) - (production :import-source (:package-name) import-source-package-name) + (production :import-binding (:package-name) import-binding-import-source) + (production :import-binding (:identifier = :package-name) import-binding-named-import-source) (production :includes-excludes () includes-excludes-none) @@ -4481,7 +4782,7 @@ (production :name-pattern-list (:qualified-identifier) name-pattern-list-one) (production :name-pattern-list (:name-pattern-list \, :qualified-identifier) name-pattern-list-more) - #| + (production :name-patterns (:name-pattern) name-patterns-one) (production :name-patterns (:name-patterns \, :name-pattern) name-patterns-more) @@ -4499,6 +4800,7 @@ |# + (? js2 (%heading 2 "Include Directive") (production :include-directive (include :no-line-break $string) include-directive-include)) @@ -4566,7 +4868,7 @@ (production :export-binding-list (:export-binding-list \, :export-binding) export-binding-list-more) (production :export-binding (:function-name) export-binding-simple) - (production :export-binding (:function-name = :function-name) export-binding-initialiser)) + (production :export-binding (:function-name = :function-name) export-binding-initializer)) (%heading 2 "Variable Definition") @@ -4588,11 +4890,11 @@ (setup (-> () void)) (eval (-> (environment) void))) (production (:variable-binding-list :beta) ((:variable-binding :beta)) variable-binding-list-one - ((validate cxt env attr immutable no-initialiser) :forward) + ((validate cxt env attr immutable no-initializer) :forward) ((setup) :forward) ((eval env) :forward)) (production (:variable-binding-list :beta) ((:variable-binding-list :beta) \, (:variable-binding :beta)) variable-binding-list-more - ((validate cxt env attr immutable no-initialiser) :forward) + ((validate cxt env attr immutable no-initializer) :forward) ((setup) :forward) ((eval env) :forward))) @@ -4606,7 +4908,7 @@ (eval (-> (environment) void)) (write-binding (-> (environment object) void))) (production (:variable-binding :beta) ((:typed-identifier :beta) (:variable-initialisation :beta)) variable-binding-full - ((validate cxt env attr immutable no-initialiser) + ((validate cxt env attr immutable no-initializer) ((validate :typed-identifier) cxt env) ((validate :variable-initialisation) cxt env) (action<- (compile-env :variable-binding 0) env) @@ -4633,24 +4935,29 @@ (:character-literal "final") " attribute"))) (case category (:select (tag none static) - (const initialiser initialiser-opt (initialiser :variable-initialisation)) - (rwhen (and no-initialiser (not-in initialiser (tag none))) + (const initializer initializer-opt (initializer :variable-initialisation)) + (rwhen (and no-initializer (not-in initializer (tag none))) (throw-error -syntax-error "a " (:character-literal "for") "-" (:character-literal "in") " statement" :apostrophe "s variable definition must not have an initialiser")) (function (variable-setup) class-opt (const type class-opt ((setup-and-eval :typed-identifier) env)) ((setup :variable-initialisation)) (return type)) - (const v variable (new variable :uninit none immutable variable-setup initialiser env)) + (const v variable (new variable :uninit none immutable variable-setup initializer env)) (const multiname multiname (define-singleton-property env name (& namespaces a) (& override-mod a) (& explicit a) read-write v)) (action<- (multiname :variable-binding 0) multiname) (action<- (compile-var :variable-binding 0) v)) (:narrow (tag virtual final) - (assert (not no-initialiser)) + (assert (not no-initializer)) (const c class (assert-in (nth env 0) class)) - (const v instance-variable (new instance-variable :uninit (in category (tag final)) (& enumerable a) :uninit :uninit immutable)) - (action<- (overridden-var :variable-binding 0) (assert-in (define-instance-property c cxt name (& namespaces a) (& override-mod a) (& explicit a) v) - instance-variable-opt)) + (const v instance-variable (new instance-variable :uninit (in category (tag final)) :uninit :uninit :uninit immutable)) + (const v-overridden instance-variable-opt (assert-in (define-instance-property c cxt name (& namespaces a) (& override-mod a) (& explicit a) v) + instance-variable-opt)) + (var enumerable boolean (& enumerable a)) + (when (and (not-in v-overridden (tag none) :narrow-true) (&opt enumerable v-overridden)) + (<- enumerable true)) + (&const= enumerable v enumerable) + (action<- (overridden-var :variable-binding 0) v-overridden) (action<- (compile-var :variable-binding 0) v)))))) ((setup) @@ -4673,15 +4980,16 @@ (if (not-in overridden-var (tag none) :narrow-true) (<- t (&opt type overridden-var)) (<- t -object))) - (&const= type v (assert-not-in t (tag none))) + (quiet-assert (not-in t (tag none) :narrow-true)) + (&const= type v t) ((setup :variable-initialisation)) - (const initialiser initialiser-opt (initialiser :variable-initialisation)) + (const initializer initializer-opt (initializer :variable-initialisation)) (var default-value object-opt none) (cond - ((not-in initialiser (tag none) :narrow-true) - (<- default-value (initialiser env compile))) + ((not-in initializer (tag none) :narrow-true) + (<- default-value (initializer env compile))) ((not (& immutable v)) - (<- default-value (& default-value (assert-not-in t (tag none)))) + (<- default-value (& default-value t)) (rwhen (in default-value (tag none)) (throw-error -uninitialized-error "Cannot declare a mutable instance variable of type " (:character-literal "Never"))))) (&const= default-value v default-value)))) @@ -4694,18 +5002,18 @@ (note "The " (:local properties) " set consists of exactly one " (:type variable) " element because " (:local inner-frame) " was constructed with that " (:type variable) " inside " (:action validate) ".") (const v variable (assert-in (unique-elt-of properties) variable)) - (const initialiser (union initialiser (tag none busy)) (& initialiser v)) - (case initialiser + (const initializer (union initializer (tag none busy)) (& initializer v)) + (case initializer (:select (tag none)) (:select (tag busy) (throw-error -reference-error)) - (:narrow initialiser - (&= initialiser v busy) - (const value object (initialiser (&opt initialiser-env v) run)) + (:narrow initializer + (&= initializer v busy) + (const value object (initializer (&opt initializer-env v) run)) (exec (write-variable v value true))))) (:select dynamic-var - (const initialiser initialiser-opt (initialiser :variable-initialisation)) - (when (not-in initialiser (tag none) :narrow-true) - (const value object (initialiser env run)) + (const initializer initializer-opt (initializer :variable-initialisation)) + (when (not-in initializer (tag none) :narrow-true) + (const value object (initializer env run)) (lexical-write env (multiname :variable-binding 0) value false run))) (:select instance-variable))) @@ -4723,24 +5031,24 @@ (rule (:variable-initialisation :beta) ((validate (-> (context environment) void)) (setup (-> () void)) - (initialiser initialiser-opt)) + (initializer initializer-opt)) (production (:variable-initialisation :beta) () variable-initialisation-none ((validate cxt env) :forward) ((setup) :forward) - (initialiser none)) - (production (:variable-initialisation :beta) (= (:variable-initialiser :beta)) variable-initialisation-variable-initialiser + (initializer none)) + (production (:variable-initialisation :beta) (= (:variable-initializer :beta)) variable-initialisation-variable-initializer ((validate cxt env) :forward) ((setup) :forward) - (initialiser (eval :variable-initialiser)))) + (initializer (eval :variable-initializer)))) - (rule (:variable-initialiser :beta) ((validate (-> (context environment) void)) (setup (-> () void)) + (rule (:variable-initializer :beta) ((validate (-> (context environment) void)) (setup (-> () void)) (eval (-> (environment phase) object))) - (production (:variable-initialiser :beta) ((:assignment-expression :beta)) variable-initialiser-assignment-expression + (production (:variable-initializer :beta) ((:assignment-expression :beta)) variable-initializer-assignment-expression ((validate cxt env) :forward) ((setup) :forward) ((eval env phase) (return (read-reference ((eval :assignment-expression) env phase) phase)))) - (production (:variable-initialiser :beta) (:attribute-combination) variable-initialiser-attribute-combination + (production (:variable-initializer :beta) (:attribute-combination) variable-initializer-attribute-combination ((validate cxt env) :forward) ((setup) :forward) ((eval env phase) (return ((eval :attribute-combination) env phase))))) @@ -4762,7 +5070,7 @@ ;(production (:typed-identifier :beta) ((:type-expression :beta) :identifier) typed-identifier-type-and-identifier) (%print-actions ("Validation" compile-env compile-var overridden-var multiname name plain immutable validate) ("Setup" setup) - ("Evaluation" setup-and-eval eval write-binding initialiser)) + ("Evaluation" setup-and-eval eval write-binding initializer)) (%heading 2 "Simple Variable Definition") @@ -4805,9 +5113,9 @@ (exec (define-hoisted-var env (name :identifier) undefined))) ((setup) ((setup :variable-initialisation))) ((eval env) - (const initialiser initialiser-opt (initialiser :variable-initialisation)) - (when (not-in initialiser (tag none) :narrow-true) - (const value object (initialiser env run)) + (const initializer initializer-opt (initializer :variable-initialisation)) + (when (not-in initializer (tag none) :narrow-true) + (const value object (initializer env run)) (const qname qualified-name (new qualified-name public (name :identifier))) (lexical-write env (list-set qname) value false run))))) (%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval)) @@ -4862,16 +5170,21 @@ (throw-error -attribute-error "an instance method cannot have the " (:character-literal "prototype") " attribute")) (const handling handling (handling :function-name)) ((validate :function-common) cxt env instance-function handling) + (const signature parameter-frame (compile-frame :function-common)) (var m instance-property) (case handling (:select (tag normal) - (<- m (new instance-method :uninit final (& enumerable a) (compile-frame :function-common) (eval-instance-call :function-common)))) + (<- m (new instance-method :uninit final :uninit signature (signature-length signature) (eval-instance-call :function-common)))) (:select (tag get) - (<- m (new instance-getter :uninit final (& enumerable a) (compile-frame :function-common) (eval-instance-get :function-common)))) + (<- m (new instance-getter :uninit final :uninit signature (eval-instance-get :function-common)))) (:select (tag set) - (<- m (new instance-setter :uninit final (& enumerable a) (compile-frame :function-common) (eval-instance-set :function-common))))) - (action<- (overridden-property :function-definition 0) - (define-instance-property c cxt (name :function-name) (& namespaces a) (& override-mod a) (& explicit a) m))) + (<- m (new instance-setter :uninit final :uninit signature (eval-instance-set :function-common))))) + (const m-overridden instance-property-opt (define-instance-property c cxt (name :function-name) (& namespaces a) (& override-mod a) (& explicit a) m)) + (var enumerable boolean (& enumerable a)) + (when (and (not-in m-overridden (tag none) :narrow-true) (&opt enumerable m-overridden)) + (<- enumerable true)) + (&const= enumerable m enumerable) + (action<- (overridden-property :function-definition 0) m-overridden)) ((validate-constructor cxt env c a) (rwhen (& prototype a) @@ -4920,7 +5233,7 @@ (:select (tag none) ((setup :function-common))) (:narrow (union instance-method instance-getter instance-setter) - ((setup-override :function-common) (& signature overridden-property))) + ((setup-override :function-common) (&opt signature overridden-property))) (:narrow instance-variable (var overridden-signature parameter-frame) (case (handling :function-name) @@ -5015,7 +5328,7 @@ (x) (if (in x return :narrow-true) (<- result (& value x)) (throw x))) - (const coerced-result object (implicit-coerce result (&opt return-type runtime-frame) false)) + (const coerced-result object (as result (&opt return-type runtime-frame) false)) (return coerced-result)) ((eval-static-get runtime-env phase) @@ -5031,7 +5344,7 @@ (x) (if (in x return :narrow-true) (<- result (& value x)) (throw x))) - (const coerced-result object (implicit-coerce result (&opt return-type runtime-frame) false)) + (const coerced-result object (as result (&opt return-type runtime-frame) false)) (return coerced-result)) ((eval-static-set new-value runtime-env phase) @@ -5060,7 +5373,7 @@ (x) (if (in x return :narrow-true) (<- result (& value x)) (throw x))) - (const coerced-result object (implicit-coerce result (&opt return-type runtime-frame) false)) + (const coerced-result object (as result (&opt return-type runtime-frame) false)) (return coerced-result)) ((eval-instance-get this phase) @@ -5078,7 +5391,7 @@ (x) (if (in x return :narrow-true) (<- result (& value x)) (throw x))) - (const coerced-result object (implicit-coerce result (&opt return-type runtime-frame) false)) + (const coerced-result object (as result (&opt return-type runtime-frame) false)) (return coerced-result)) ((eval-instance-set this new-value phase) @@ -5115,11 +5428,11 @@ (rwhen (in phase (tag compile) :narrow-false) (throw-error -constant-error "constant expressions cannot call user-defined prototype constructors")) (const runtime-env environment (assert-not-in (& env f) (tag none))) - (var super object (dot-read f (list-set (new qualified-name public "prototype")) phase)) + (var archetype object (dot-read f (list-set (new qualified-name public "prototype")) phase)) (cond - ((in super (tag null undefined)) (<- super -object-prototype)) - ((/= (object-type super) -object class) (throw-error -type-error "bad " (:character-literal "prototype") " value"))) - (var o object (create-simple-instance -object super none none none)) + ((in archetype (tag null undefined)) (<- archetype -object-prototype)) + ((/= (object-type archetype) -object class) (throw-error -type-error "bad " (:character-literal "prototype") " value"))) + (var o object (create-simple-instance -object archetype none none none)) (const compile-frame parameter-frame (compile-frame :function-common 0)) (const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame runtime-env o)) (assign-arguments runtime-frame f args phase) @@ -5129,7 +5442,7 @@ (x) (if (in x return :narrow-true) (<- result (& value x)) (throw x))) - (const coerced-result object (implicit-coerce result (&opt return-type runtime-frame) false)) + (const coerced-result object (as result (&opt return-type runtime-frame) false)) (if (in coerced-result primitive-object) (return o) (return coerced-result))) @@ -5196,7 +5509,7 @@ (when (not-in arguments-object (tag none) :narrow-true) (note "Create an alias of " (:local v) " as the " (:local i) "th entry of the " (:character-literal "arguments") " object.") (assert (in v dynamic-var)) - (const qname qualified-name (to-qualified-name (new u-long i) phase)) + (const qname qualified-name (object-to-qualified-name (new u-long i) phase)) (&= local-bindings (assert-in arguments-object simple-instance) (set+ (& local-bindings (assert-in arguments-object simple-instance)) (list-set (new local-binding qname read-write false false v)))))) ((not-in rest-object (tag none) :narrow-true) @@ -5219,10 +5532,15 @@ (<- default undefined) (throw-error -argument-error "fewer arguments than parameters were supplied, and the called function does not supply default values for the missing parameters and is not unchecked."))) - (write-singleton-property (& var parameter) (assert-not-in default (tag none)) phase) + (quiet-assert (not-in default (tag none) :narrow-true)) + (write-singleton-property (& var parameter) default phase) (<- i (+ i 1)))) + (define (signature-length (signature parameter-frame)) integer + (return (length (&opt parameters signature)))) + + (rule :parameters ((plain boolean) (parameter-count integer) (validate (-> (context environment parameter-frame) void)) (setup (-> (environment parameter-frame) void)) @@ -5321,7 +5639,8 @@ (var type class-opt ((setup-and-eval :typed-identifier) compile-env)) (when (in type (tag none)) (<- type -object)) - (&const= type v (assert-not-in type (tag none))))) + (quiet-assert (not-in type (tag none) :narrow-true)) + (&const= type v type))) (when (in compile-frame parameter-frame :narrow-true) (const p parameter (new parameter v default)) (&= parameters compile-frame (append (&opt parameters compile-frame) (vector p))))) @@ -5336,9 +5655,10 @@ (var type class-opt ((setup-and-eval :typed-identifier) compile-env)) (when (in type (tag none)) (<- type -object)) - (rwhen (/= (assert-not-in type (tag none)) (&opt type (assert-not-in (& var overridden-parameter) dynamic-var)) class) + (quiet-assert (not-in type (tag none) :narrow-true)) + (rwhen (/= type (&opt type (assert-not-in (& var overridden-parameter) dynamic-var)) class) (throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature")) - (&const= type v (assert-not-in type (tag none))) + (&const= type v type) (const p parameter (new parameter v new-default)) (&= parameters compile-frame (append (&opt parameters compile-frame) (vector p)))))) @@ -5362,7 +5682,7 @@ ((setup :parameter) compile-env compile-frame none)) ((setup-override compile-env compile-frame overridden-parameter) ((setup-override :parameter) compile-env compile-frame none overridden-parameter))) - (production :parameter-init (:parameter = (:assignment-expression allow-in)) parameter-init-initialiser + (production :parameter-init (:parameter = (:assignment-expression allow-in)) parameter-init-initializer (plain false) ((validate cxt env compile-frame) ((validate :parameter) cxt env compile-frame) @@ -5452,18 +5772,18 @@ (const private-namespace namespace (new namespace "private")) (const dynamic boolean (or (& dynamic a) (and (& dynamic super) (/= super -object class)))) (const c class (new class - (list-set-of local-binding) super (list-set-of instance-property) (&opt prototype super) false - (name :identifier) "object" private-namespace dynamic final null + (list-set-of local-binding) (list-set-of instance-property) super (&opt prototype super) false + (name :identifier) "object" private-namespace dynamic final null hint-number (& bracket-read super) (& bracket-write super) (& bracket-delete super) (& read super) (& write super) (& delete super) (& enumerate super) - :uninit :uninit none ordinary-is ordinary-implicit-coerce-null)) + :uninit :uninit none ordinary-is ordinary-as)) (function (c-call (this object :unused) (args (vector object)) (phase phase :unused)) object (rwhen (not (& complete c)) (throw-error -constant-error "cannot coerce to a class before its definition has been compiled")) (rwhen (/= (length args) 1) (throw-error -argument-error "exactly one argument must be supplied")) - (return (implicit-coerce (nth args 0) c false))) + (return (as (nth args 0) c false))) (&const= call c c-call) (function (c-construct (args (vector object)) (phase phase)) object (rwhen (not (& complete c)) @@ -5532,7 +5852,7 @@ ((validate (cxt :unused) env preinst attr) (rwhen (not preinst) (throw-error -syntax-error "a namespace may be defined only in a preinstantiated scope")) - (var a compound-attribute (to-compound-attribute attr)) + (const a compound-attribute (to-compound-attribute attr)) (rwhen (& dynamic a) (throw-error -attribute-error "a namespace definition cannot have the " (:character-literal "dynamic") " attribute")) (rwhen (& prototype a) @@ -5552,87 +5872,129 @@ (%print-actions ("Validation" validate)) - (? js2 - (%heading 2 "Package Definition") - (production :package-definition (package :block) package-definition-anonymous) - (production :package-definition (package :package-name :block) package-definition-named) - - (production :package-name (:identifier) package-name-one) - (production :package-name (:package-name \. :identifier) package-name-more)) - - (%heading 1 "Programs") - (rule :program ((eval-program object)) + (rule :program ((process object)) (production :program (:directives) program-directives - (eval-program + (process (begin (const cxt context (new context false (list-set public internal))) (const initial-environment environment (vector-of frame (create-global-object))) ((validate :directives) cxt initial-environment (new jump-targets (list-set-of label) (list-set-of label)) true none) ((setup :directives)) - (return ((eval :directives) initial-environment undefined)))))) - (%print-actions ("Evaluation" eval-program)) + (return ((eval :directives) initial-environment undefined))))) + (production :program (:package-definition :program) program-package-and-program + (process + (begin + (process :package-definition) + (return (process :program)))))) + (%print-actions ("Processing" process)) + (%heading 2 "Package Definition") + (rule :package-definition ((process void)) + (production :package-definition (package :package-name-opt :block) package-definition-name-and-block + (process + (begin + (const name string (name :package-name-opt)) + (const cxt context (new context false (list-set public internal))) + (const global-object package (create-global-object)) + (const pkg-internal namespace (new namespace "internal")) + (const pkg package (new package + (list-set (std-explicit-const-binding (new qualified-name internal "internal") -namespace internal)) + -object-prototype name busy true pkg-internal)) + (const initial-environment environment (vector-of frame pkg global-object)) + ((validate :block) cxt initial-environment (new jump-targets (list-set-of label) (list-set-of label)) true) + ((setup :block)) + (function (eval-package) void + (&= initialize pkg busy) + (exec ((eval :block) initial-environment undefined)) + (&= initialize pkg none)) + (&= initialize pkg eval-package) + (/* "Bind " (:local name) " to package " (:local pkg) " in the system" :apostrophe "s list of packages in an implementation-defined manner.") + (<- package-database (set+ package-database (list-set pkg))) + (*/))))) + + + (rule :package-name-opt ((name string)) + (production :package-name-opt () package-name-opt-none + (name (/*/ "" "an implementation-supplied name"))) + (production :package-name-opt (:package-name) package-name-opt-package-name + (name (name :package-name)))) + + (rule :package-name ((name string)) + (production :package-name ($string) package-name-string + (name (/*/ (value $string) (:expr string (value $string)) " processed in an implementation-defined manner"))) + (production :package-name (:package-identifiers) package-name-package-identifiers + (name (/*/ (nth (names :package-identifiers) 0) (:expr (vector string) (names :package-identifiers)) " processed in an implementation-defined manner")))) + + (rule :package-identifiers ((names (vector string))) + (production :package-identifiers (:identifier) package-identifiers-one + (names (vector (name :identifier)))) + (production :package-identifiers (:package-identifiers \. :identifier) package-identifiers-more + (names (append (names :package-identifiers) (vector (name :identifier)))))) + (%print-actions ("Processing" process name names)) + + (defvar package-database (list-set package) (list-set-of package)) + (%heading (1 :semantics) "Predefined Identifiers") (define (create-global-object) package (return (new package - (list-set - (new local-binding (new qualified-name internal "internal") read-write true false (new variable -namespace internal true none none :uninit)) + (%list-set + (std-explicit-const-binding (new qualified-name internal "internal") -namespace internal) - (new local-binding (new qualified-name public "explicit") read-write false false (new variable -attribute explicit-attribute true none none :uninit)) - (new local-binding (new qualified-name public "enumerable") read-write false false (new variable -attribute enumerable-attribute true none none :uninit)) - (new local-binding (new qualified-name public "dynamic") read-write false false (new variable -attribute dynamic-attribute true none none :uninit)) - (new local-binding (new qualified-name public "static") read-write false false (new variable -attribute static-attribute true none none :uninit)) - (new local-binding (new qualified-name public "virtual") read-write false false (new variable -attribute virtual-attribute true none none :uninit)) - (new local-binding (new qualified-name public "final") read-write false false (new variable -attribute final-attribute true none none :uninit)) - (new local-binding (new qualified-name public "prototype") read-write false false (new variable -attribute prototype-attribute true none none :uninit)) - (new local-binding (new qualified-name public "unused") read-write false false (new variable -attribute unused-attribute true none none :uninit)) - (new local-binding (new qualified-name public "override") read-write false false (new variable -function override-attribute true none none :uninit)) + (std-const-binding (new qualified-name public "explicit") -attribute global_explicit) + (std-const-binding (new qualified-name public "enumerable") -attribute global_enumerable) + (std-const-binding (new qualified-name public "dynamic") -attribute global_dynamic) + (std-const-binding (new qualified-name public "static") -attribute global_static) + (std-const-binding (new qualified-name public "virtual") -attribute global_virtual) + (std-const-binding (new qualified-name public "final") -attribute global_final) + (std-const-binding (new qualified-name public "prototype") -attribute global_prototype) + (std-const-binding (new qualified-name public "unused") -attribute global_unused) + (std-function (new qualified-name public "override") global_override 1) - (new local-binding (new qualified-name public "Object") read-write false false (new variable -class -object true none none :uninit)) - (new local-binding (new qualified-name public "Never") read-write false false (new variable -class -never true none none :uninit)) - (new local-binding (new qualified-name public "Void") read-write false false (new variable -class -void true none none :uninit)) - (new local-binding (new qualified-name public "Null") read-write false false (new variable -class -null true none none :uninit)) - (new local-binding (new qualified-name public "Boolean") read-write false false (new variable -class -boolean true none none :uninit)) - (new local-binding (new qualified-name public "GeneralNumber") read-write false false (new variable -class -general-number true none none :uninit)) - (new local-binding (new qualified-name public "long") read-write false false (new variable -class \#long true none none :uninit)) - (new local-binding (new qualified-name public "ulong") read-write false false (new variable -class ulong true none none :uninit)) - (new local-binding (new qualified-name public "float") read-write false false (new variable -class float true none none :uninit)) - (new local-binding (new qualified-name public "Number") read-write false false (new variable -class -number true none none :uninit)) - (new local-binding (new qualified-name public "sbyte") read-write false false (new variable -class sbyte true none none :uninit)) - (new local-binding (new qualified-name public "byte") read-write false false (new variable -class byte true none none :uninit)) - (new local-binding (new qualified-name public "short") read-write false false (new variable -class short true none none :uninit)) - (new local-binding (new qualified-name public "ushort") read-write false false (new variable -class ushort true none none :uninit)) - (new local-binding (new qualified-name public "int") read-write false false (new variable -class int true none none :uninit)) - (new local-binding (new qualified-name public "uint") read-write false false (new variable -class uint true none none :uninit)) - (new local-binding (new qualified-name public "Character") read-write false false (new variable -class -character true none none :uninit)) - (new local-binding (new qualified-name public "String") read-write false false (new variable -class -string true none none :uninit)) - (new local-binding (new qualified-name public "Array") read-write false false (new variable -class -array true none none :uninit)) - (new local-binding (new qualified-name public "Namespace") read-write false false (new variable -class -namespace true none none :uninit)) - (new local-binding (new qualified-name public "Attribute") read-write false false (new variable -class -attribute true none none :uninit)) - (new local-binding (new qualified-name public "Date") read-write false false (new variable -class -date true none none :uninit)) - (new local-binding (new qualified-name public "RegExp") read-write false false (new variable -class -reg-exp true none none :uninit)) - (new local-binding (new qualified-name public "Class") read-write false false (new variable -class -class true none none :uninit)) - (new local-binding (new qualified-name public "Function") read-write false false (new variable -class -function true none none :uninit)) - (new local-binding (new qualified-name public "PrototypeFunction") read-write false false (new variable -class -prototype-function true none none :uninit)) - (new local-binding (new qualified-name public "Package") read-write false false (new variable -class -package true none none :uninit)) - (new local-binding (new qualified-name public "Error") read-write false false (new variable -class -error true none none :uninit)) - (new local-binding (new qualified-name public "ArgumentError") read-write false false (new variable -class -argument-error true none none :uninit)) - (new local-binding (new qualified-name public "AttributeError") read-write false false (new variable -class -attribute-error true none none :uninit)) - (new local-binding (new qualified-name public "ConstantError") read-write false false (new variable -class -constant-error true none none :uninit)) - (new local-binding (new qualified-name public "DefinitionError") read-write false false (new variable -class -definition-error true none none :uninit)) - (new local-binding (new qualified-name public "EvalError") read-write false false (new variable -class -eval-error true none none :uninit)) - (new local-binding (new qualified-name public "RangeError") read-write false false (new variable -class -range-error true none none :uninit)) - (new local-binding (new qualified-name public "ReferenceError") read-write false false (new variable -class -reference-error true none none :uninit)) - (new local-binding (new qualified-name public "SyntaxError") read-write false false (new variable -class -syntax-error true none none :uninit)) - (new local-binding (new qualified-name public "TypeError") read-write false false (new variable -class -type-error true none none :uninit)) - (new local-binding (new qualified-name public "UninitializedError") read-write false false (new variable -class -uninitialized-error true none none :uninit)) - (new local-binding (new qualified-name public "URIError") read-write false false (new variable -class -u-r-i-error true none none :uninit)) + (std-const-binding (new qualified-name public "Object") -class -object) + (std-const-binding (new qualified-name public "Never") -class -never) + (std-const-binding (new qualified-name public "Void") -class -void) + (std-const-binding (new qualified-name public "Null") -class -null) + (std-const-binding (new qualified-name public "Boolean") -class -boolean) + (std-const-binding (new qualified-name public "GeneralNumber") -class -general-number) + (std-const-binding (new qualified-name public "long") -class \#long) + (std-const-binding (new qualified-name public "ulong") -class ulong) + (std-const-binding (new qualified-name public "float") -class float) + (std-const-binding (new qualified-name public "Number") -class -number) + (std-const-binding (new qualified-name public "sbyte") -class sbyte) + (std-const-binding (new qualified-name public "byte") -class byte) + (std-const-binding (new qualified-name public "short") -class short) + (std-const-binding (new qualified-name public "ushort") -class ushort) + (std-const-binding (new qualified-name public "int") -class int) + (std-const-binding (new qualified-name public "uint") -class uint) + (std-const-binding (new qualified-name public "Character") -class -character) + (std-const-binding (new qualified-name public "String") -class -string) + (std-const-binding (new qualified-name public "Array") -class -array) + (std-const-binding (new qualified-name public "Namespace") -class -namespace) + (std-const-binding (new qualified-name public "Attribute") -class -attribute) + (std-const-binding (new qualified-name public "Date") -class -date) + (std-const-binding (new qualified-name public "RegExp") -class -reg-exp) + (std-const-binding (new qualified-name public "Class") -class -class) + (std-const-binding (new qualified-name public "Function") -class -function) + (std-const-binding (new qualified-name public "PrototypeFunction") -class -prototype-function) + (std-const-binding (new qualified-name public "Package") -class -package) + (std-const-binding (new qualified-name public "Error") -class -error) + (std-const-binding (new qualified-name public "ArgumentError") -class -argument-error) + (std-const-binding (new qualified-name public "AttributeError") -class -attribute-error) + (std-const-binding (new qualified-name public "ConstantError") -class -constant-error) + (std-const-binding (new qualified-name public "DefinitionError") -class -definition-error) + (std-const-binding (new qualified-name public "EvalError") -class -eval-error) + (std-const-binding (new qualified-name public "RangeError") -class -range-error) + (std-const-binding (new qualified-name public "ReferenceError") -class -reference-error) + (std-const-binding (new qualified-name public "SyntaxError") -class -syntax-error) + (std-const-binding (new qualified-name public "TypeError") -class -type-error) + (std-const-binding (new qualified-name public "UninitializedError") -class -uninitialized-error) + (std-const-binding (new qualified-name public "URIError") -class -u-r-i-error) ) - -object-prototype false internal))) + -object-prototype "" none false internal))) (%heading (2 :semantics) "Built-in Namespaces") @@ -5640,16 +6002,16 @@ (define internal namespace (new namespace "internal")) (%heading (2 :semantics) "Built-in Attributes") - (define explicit-attribute compound-attribute (new compound-attribute (list-set-of namespace) true false false none none false false)) - (define enumerable-attribute compound-attribute (new compound-attribute (list-set-of namespace) false true false none none false false)) - (define dynamic-attribute compound-attribute (new compound-attribute (list-set-of namespace) false false true none none false false)) - (define static-attribute compound-attribute (new compound-attribute (list-set-of namespace) false false false static none false false)) - (define virtual-attribute compound-attribute (new compound-attribute (list-set-of namespace) false false false virtual none false false)) - (define final-attribute compound-attribute (new compound-attribute (list-set-of namespace) false false false final none false false)) - (define prototype-attribute compound-attribute (new compound-attribute (list-set-of namespace) false false false none none true false)) - (define unused-attribute compound-attribute (new compound-attribute (list-set-of namespace) false false false none none false true)) - (define override-attribute simple-instance (system-function call-override-attribute 1)) - (define (call-override-attribute (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase :unused)) object + (define global_explicit compound-attribute (new compound-attribute (list-set-of namespace) true false false none none false false)) + (define global_enumerable compound-attribute (new compound-attribute (list-set-of namespace) false true false none none false false)) + (define global_dynamic compound-attribute (new compound-attribute (list-set-of namespace) false false true none none false false)) + (define global_static compound-attribute (new compound-attribute (list-set-of namespace) false false false static none false false)) + (define global_virtual compound-attribute (new compound-attribute (list-set-of namespace) false false false virtual none false false)) + (define global_final compound-attribute (new compound-attribute (list-set-of namespace) false false false final none false false)) + (define global_prototype compound-attribute (new compound-attribute (list-set-of namespace) false false false none none true false)) + (define global_unused compound-attribute (new compound-attribute (list-set-of namespace) false false false none none false true)) + (define (global_override (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase :unused)) object + (note "This function does not check " (:local phase) " and therefore can be used in constant expressions.") (var override-mod override-modifier) (cond ((empty args) (<- override-mod true)) @@ -5661,6 +6023,7 @@ (nil (throw-error -argument-error "too many arguments supplied"))) (return (new compound-attribute (list-set-of namespace) false false false none override-mod false false))) + (%heading (2 :semantics) "Built-in Functions") @@ -5677,143 +6040,537 @@ (%heading (2 :semantics) "Object") (define -object class (new class - (list-set-of local-binding) none (list-set-of instance-property) (:delay -object-prototype) true - "Object" "object" :uninit true false undefined + (list-set-of local-binding) (list-set-of instance-property) none (delay -object-prototype) true + "Object" "object" :uninit true false undefined hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + call-object construct-object none ordinary-is as-object)) + + (define (call-object (this object :unused) (args (vector object)) (phase phase :unused)) object + (note "This function does not check " (:local phase) " and therefore can be used in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (return (default-arg args 0 undefined))) + + (define (construct-object (args (vector object)) (phase phase)) object + (return (call-object null args phase))) + + (define (as-object (o object) (c class :unused) (silent boolean :unused)) object + (return o)) (define -object-prototype simple-instance (new simple-instance - (list-set-of local-binding) + (%list-set + (std-const-binding (new qualified-name public "constructor") -class -object) + (std-function (new qualified-name public "toString") -object_to-string 0) + (std-function (new qualified-name public "toLocaleString") -object_to-locale-string 0) + (std-function (new qualified-name public "valueOf") -object_value-of 0) + (std-function (new qualified-name public "hasOwnProperty") -object_has-own-property 1) + (std-function (new qualified-name public "isPrototypeOf") -object_is-prototype-of 1) + (std-function (new qualified-name public "propertyIsEnumerable") -object_property-is-enumerable 1) + (std-function (new qualified-name public "sealProperty") -object_seal-property 1)) none prototypes-sealed -object (list-set-of slot) none none none)) - ;***** Add some properties here + + + (define (-object_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object + (note "This function does not check " (:local phase) " and therefore can be used in constant expressions.") + (note "This function ignores any arguments passed to it in " (:local args) ".") + (const c class (object-type this)) + (return (append "[object " (& name c) "]"))) + + + (define (-object_to-locale-string (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "toLocaleString") " cannot be called from constant expressions")) + (const to-string-method object (dot-read this (list-set (new qualified-name public "toString")) phase)) + (return (call this to-string-method args phase))) + + + (define (-object_value-of (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object + (note "This function does not check " (:local phase) " and therefore can be used in constant expressions.") + (note "This function ignores any arguments passed to it in " (:local args) ".") + (return this)) + + + (define (-object_has-own-property (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "hasOwnProperty") " cannot be called from constant expressions")) + (rwhen (/= (length args) 1) + (throw-error -argument-error "exactly one argument must be supplied")) + (const qname qualified-name (object-to-qualified-name (nth args 0) phase)) + (return (has-property this qname true))) + + + (define (-object_is-prototype-of (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "isPrototypeOf") " cannot be called from constant expressions")) + (rwhen (/= (length args) 1) + (throw-error -argument-error "exactly one argument must be supplied")) + (const o object (nth args 0)) + (return (set-in this (archetypes o)))) + + + (define (-object_property-is-enumerable (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "propertyIsEnumerable") " cannot be called from constant expressions")) + (rwhen (/= (length args) 1) + (throw-error -argument-error "exactly one argument must be supplied")) + (const qname qualified-name (object-to-qualified-name (nth args 0) phase)) + (const c class (object-type this)) + (var m-base instance-property-opt (find-base-instance-property c (list-set qname) read)) + (when (not-in m-base (tag none) :narrow-true) + (const m instance-property (get-derived-instance-property c m-base read)) + (rwhen (&opt enumerable m) + (return true))) + (<- m-base (find-base-instance-property c (list-set qname) write)) + (when (not-in m-base (tag none) :narrow-true) + (const m instance-property (get-derived-instance-property c m-base write)) + (rwhen (&opt enumerable m) + (return true))) + (rwhen (not-in this binding-object :narrow-false) + (return false)) + (return (some (& local-bindings this) b (and (= (& qname b) qname qualified-name) (& enumerable b))))) + + + (define (-object_seal-property (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "sealProperty") " cannot be called from constant expressions")) + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const arg object (default-arg args 0 true)) + (cond + ((in arg (tag false) :narrow-false) + (seal-object this)) + ((in arg (tag true) :narrow-false) + (seal-object this) + (seal-all-local-properties this)) + ((in arg (union char16 string)) + (const qname qualified-name (object-to-qualified-name arg phase)) + (rwhen (not (has-property this qname true)) + (throw-error -reference-error "property not found")) + (seal-local-property this qname))) + (return undefined)) + (%heading (2 :semantics) "Never") (define -never class (new class - (list-set-of local-binding) -object (list-set-of instance-property) none true - "Never" "" :uninit false true none + (list-set-of local-binding) (list-set-of instance-property) -object none true + "Never" "" :uninit false true none :uninit ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-no-null)) + call-never construct-never none ordinary-is as-never)) + + (define (call-never (this object :unused) (args (vector object)) (phase phase :unused)) object + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (throw-error -type-error "no coercions to " (:character-literal "Never") " are possible")) + + (define (construct-never (args (vector object)) (phase phase)) object + (return (call-never null args phase))) + + (define (as-never (o object :unused) (c class :unused) (silent boolean :unused)) object + (throw-error -type-error "no coercions to " (:character-literal "Never") " are possible")) (%heading (2 :semantics) "Void") (define -void class (new class - (list-set-of local-binding) -object (list-set-of instance-property) none true - "Void" "undefined" :uninit false true undefined + (list-set-of local-binding) (list-set-of instance-property) -object none true + "Void" "undefined" :uninit false true undefined :uninit ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-no-null)) + call-void construct-void none ordinary-is as-void)) + + (define (call-void (this object :unused) (args (vector object)) (phase phase :unused)) undefined + (note "This function does not check " (:local phase) " and therefore can be used in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (return undefined)) + + (define (construct-void (args (vector object)) (phase phase :unused)) undefined + (note "This function does not check " (:local phase) " and therefore can be used in constant expressions.") + (rwhen (/= (length args) 0) + (throw-error -argument-error "no arguments can be supplied")) + (return undefined)) + + (define (as-void (o object) (c class :unused) (silent boolean :unused)) undefined + (if (in o (union null undefined)) + (return undefined) + (throw-error -type-error))) (%heading (2 :semantics) "Null") (define -null class (new class - (list-set-of local-binding) -object (list-set-of instance-property) none true - "Null" "object" :uninit false true null + (list-set-of local-binding) (list-set-of instance-property) -object none true + "Null" "object" :uninit false true null :uninit ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + call-null construct-null none ordinary-is as-null)) + + (define (call-null (this object :unused) (args (vector object)) (phase phase :unused)) null + (note "This function does not check " (:local phase) " and therefore can be used in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (return null)) + + (define (construct-null (args (vector object)) (phase phase :unused)) null + (note "This function does not check " (:local phase) " and therefore can be used in constant expressions.") + (rwhen (/= (length args) 0) + (throw-error -argument-error "no arguments can be supplied")) + (return null)) + + (define (as-null (o object) (c class :unused) (silent boolean :unused)) null + (if (in o (tag null) :narrow-true) + (return o) + (throw-error -type-error))) (%heading (2 :semantics) "Boolean") (define -boolean class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -boolean-prototype) true - "Boolean" "boolean" :uninit false true false + (list-set-of local-binding) (list-set-of instance-property) -object (delay -boolean-prototype) true + "Boolean" "boolean" :uninit false true false :uninit ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-no-null)) + call-boolean construct-boolean none ordinary-is as-boolean)) + + (define (call-boolean (this object :unused) (args (vector object)) (phase phase :unused)) object + (note "This function does not check " (:local phase) " and therefore can be used in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (return (object-to-boolean (default-arg args 0 false)))) + + (define (construct-boolean (args (vector object)) (phase phase)) object + (return (call-boolean null args phase))) + + (define (as-boolean (o object) (c class :unused) (silent boolean :unused)) object + (if (in o boolean :narrow-true) + (return o) + (throw-error -type-error))) (define -boolean-prototype simple-instance (new simple-instance - (list-set-of local-binding) + (%list-set + (std-const-binding (new qualified-name public "constructor") -class -boolean) + (std-function (new qualified-name public "toString") -boolean_to-string 0)) -object-prototype prototypes-sealed -object (list-set-of slot) none none none)) - ;***** Add some properties here + + + (define (-boolean_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) object + (note "This function can be used in constant expressions.") + (note "This function ignores any arguments passed to it in " (:local args) ".") + (const a boolean (object-to-boolean this)) + (return (object-to-string a phase))) (%heading (2 :semantics) "GeneralNumber") (define -general-number class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -general-number-prototype) true - "GeneralNumber" "object" :uninit false false nan64 + (list-set-of local-binding) (list-set-of instance-property) -object (delay -general-number-prototype) true + "GeneralNumber" "object" :uninit false false nan64 hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-no-null)) + call-general-number construct-general-number none ordinary-is as-general-number)) + + (define (call-general-number (this object :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const arg object (default-arg args 0 +zero64)) + (return (object-to-general-number arg phase))) + + (define (construct-general-number (args (vector object)) (phase phase)) object + (return (call-general-number null args phase))) + + (define (as-general-number (o object) (c class :unused) (silent boolean :unused)) general-number + (if (in o general-number :narrow-true) + (return o) + (throw-error -type-error))) (define -general-number-prototype simple-instance (new simple-instance - (list-set-of local-binding) + (%list-set + (std-const-binding (new qualified-name public "constructor") -class -general-number) + (std-function (new qualified-name public "toString") -general-number_to-string 1) + (std-function (new qualified-name public "toFixed") -general-number_to-fixed 1) + (std-function (new qualified-name public "toExponential") -general-number_to-exponential 1) + (std-function (new qualified-name public "toPrecision") -general-number_to-precision 1)) -object-prototype prototypes-sealed -object (list-set-of slot) none none none)) - ;***** Add some properties here + + + (define (-general-number_to-string (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the argument can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a general number.") + (const x general-number (object-to-general-number this phase)) + (var radix extended-integer (object-to-imprecise-integer (default-arg args 0 10.0) phase)) + (when (in radix (tag nan)) + (<- radix 10)) + (quiet-assert (not-in radix (tag nan) :narrow-true)) + (rwhen (or (in radix (tag +infinity -infinity) :narrow-false) (< radix 2) (> radix 36)) + (throw-error -range-error "bad radix")) + (if (= radix 10) + (return (general-number-to-string x)) + (return (/*/ "*****Implementation-defined" (:local x) " converted to a string containing a base-" (:local radix) " number in an implementation-defined manner")))) + + + (define precision-limit integer (/*/ 100 "an implementation-defined integer not less than 20")) + + (define (-general-number_to-fixed (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the argument can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a general number.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const x general-number (object-to-general-number this phase)) + (var fraction-digits extended-integer (object-to-imprecise-integer (default-arg args 0 +zero64) phase)) + (when (in fraction-digits (tag nan)) + (<- fraction-digits 0)) + (quiet-assert (not-in fraction-digits (tag nan) :narrow-true)) + (rwhen (or (in fraction-digits (tag +infinity -infinity) :narrow-false) (< fraction-digits 0) (> fraction-digits precision-limit)) + (throw-error -range-error)) + (rwhen (not-in x finite-general-number :narrow-false) + (return (general-number-to-string x))) + (var r rational (to-rational x)) + (when (>= (rat-abs r) (expt 10 21) rational) + (return (general-number-to-string x))) + (var sign string "") + (when (< r 0 rational) + (<- sign "-") + (<- r (rat-neg r))) + (const n integer (floor (rat+ (rat* r (expt 10 fraction-digits)) (rat/ 1 2)))) + (var digits string (integer-to-string n)) + (when (> fraction-digits 0) + (when (<= (length digits) fraction-digits) + (<- digits (append (repeat char16 #\0 (- (+ fraction-digits 1) (length digits))) digits))) + (const k integer (- (length digits) fraction-digits)) + (<- digits (append (subseq digits 0 (- k 1)) "." (subseq digits k)))) + (return (append sign digits))) + + + (define (-general-number_to-exponential (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the argument can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a general number.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const x general-number (object-to-general-number this phase)) + (var fraction-digits extended-integer (object-to-imprecise-integer (default-arg args 0 +zero64) phase)) + (when (in fraction-digits (tag nan)) + (todo)) + (quiet-assert (not-in fraction-digits (tag nan) :narrow-true)) + (rwhen (or (in fraction-digits (tag +infinity -infinity) :narrow-false) (< fraction-digits 0) (> fraction-digits precision-limit)) + (throw-error -range-error)) + (rwhen (not-in x finite-general-number :narrow-false) + (return (general-number-to-string x))) + (var r rational (to-rational x)) + (todo)) + + + (define (-general-number_to-precision (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the argument can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a general number.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const x general-number (object-to-general-number this phase)) + (var fraction-digits extended-integer (object-to-imprecise-integer (default-arg args 0 +zero64) phase)) + (when (in fraction-digits (tag nan)) + (todo)) + (quiet-assert (not-in fraction-digits (tag nan) :narrow-true)) + (rwhen (or (in fraction-digits (tag +infinity -infinity) :narrow-false) (< fraction-digits 0) (> fraction-digits precision-limit)) + (throw-error -range-error)) + (rwhen (not-in x finite-general-number :narrow-false) + (return (general-number-to-string x))) + (var r rational (to-rational x)) + (todo)) (%heading (2 :semantics) "long") (define \#long class (new class - (list-set-of local-binding) -general-number (list-set-of instance-property) (:delay -general-number-prototype) true - "long" "long" :uninit false true (new long 0) + (%list-set + (std-const-binding (new qualified-name public "MAX_VALUE") (delay ulong) (new long (- (expt 2 63) 1))) + (std-const-binding (new qualified-name public "MIN_VALUE") (delay ulong) (new long (neg (expt 2 63))))) + (list-set-of instance-property) -general-number (delay long-prototype) true + "long" "long" :uninit false true (new long 0) :uninit ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-no-null)) + call-long construct-long none ordinary-is as-long)) + + (define (call-long (this object :unused) (args (vector object)) (phase phase)) long + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const arg object (default-arg args 0 +zero64)) + (const i integer (object-to-precise-integer arg phase)) + (if (cascade integer (neg (expt 2 63)) <= i <= (- (expt 2 63) 1)) + (return (new long i)) + (throw-error -range-error (:local i) " is out of the " (:type long) " range"))) + + (define (construct-long (args (vector object)) (phase phase)) long + (return (call-long null args phase))) + + (define (as-long (o object) (c class :unused) (silent boolean :unused)) long + (rwhen (not-in o general-number :narrow-false) + (throw-error -type-error)) + (const i integer-opt (check-integer o)) + (if (and (not-in i (tag none) :narrow-true) (cascade integer (neg (expt 2 63)) <= i <= (- (expt 2 63) 1))) + (return (new long i)) + (throw-error -range-error (:local i) " is out of the " (:type long) " range"))) + + (define long-prototype simple-instance + (new simple-instance + (%list-set (std-const-binding (new qualified-name public "constructor") -class \#long)) + -general-number-prototype prototypes-sealed -object + (list-set-of slot) none none none)) (%heading (2 :semantics) "ulong") (define ulong class (new class - (list-set-of local-binding) -general-number (list-set-of instance-property) (:delay -general-number-prototype) true - "ulong" "ulong" :uninit false true (new u-long 0) + (%list-set + (std-const-binding (new qualified-name public "MAX_VALUE") (delay ulong) (new u-long (- (expt 2 64) 1))) + (std-const-binding (new qualified-name public "MIN_VALUE") (delay ulong) (new u-long 0))) + (list-set-of instance-property) -general-number (delay ulong-prototype) true + "ulong" "ulong" :uninit false true (new u-long 0) :uninit ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-no-null)) + call-u-long construct-u-long none ordinary-is as-u-long)) + + (define (call-u-long (this object :unused) (args (vector object)) (phase phase)) u-long + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const arg object (default-arg args 0 +zero64)) + (const i integer (object-to-precise-integer arg phase)) + (if (cascade integer 0 <= i <= (- (expt 2 64) 1)) + (return (new u-long i)) + (throw-error -range-error (:local i) " is out of the " (:type u-long) " range"))) + + (define (construct-u-long (args (vector object)) (phase phase)) u-long + (return (call-u-long null args phase))) + + (define (as-u-long (o object) (c class :unused) (silent boolean :unused)) u-long + (rwhen (not-in o general-number :narrow-false) + (throw-error -type-error)) + (const i integer-opt (check-integer o)) + (if (and (not-in i (tag none) :narrow-true) (cascade integer 0 <= i <= (- (expt 2 64) 1))) + (return (new u-long i)) + (throw-error -range-error (:local i) " is out of the " (:type u-long) " range"))) + + (define ulong-prototype simple-instance + (new simple-instance + (%list-set (std-const-binding (new qualified-name public "constructor") -class ulong)) + -general-number-prototype prototypes-sealed -object + (list-set-of slot) none none none)) (%heading (2 :semantics) "float") (define float class (new class - (list-set-of local-binding) -general-number (list-set-of instance-property) (:delay -general-number-prototype) true - "float" "float" :uninit false true nan32 + (%list-set + (std-const-binding (new qualified-name public "MAX_VALUE") (delay float) (float32 3.4028235e+38)) + (std-const-binding (new qualified-name public "MIN_VALUE") (delay float) (float32 1e-45)) + (std-const-binding (new qualified-name public "NaN") (delay float) nan32) + (std-const-binding (new qualified-name public "NEGATIVE_INFINITY") (delay float) -infinity32) + (std-const-binding (new qualified-name public "POSITIVE_INFINITY") (delay float) +infinity32)) + (list-set-of instance-property) -general-number (delay float-prototype) true + "float" "float" :uninit false true nan32 :uninit ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-no-null)) + call-float construct-float none ordinary-is as-float)) + + (define (call-float (this object :unused) (args (vector object)) (phase phase)) float32 + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const arg object (default-arg args 0 +zero32)) + (return (object-to-float32 arg phase))) + + (define (construct-float (args (vector object)) (phase phase)) float32 + (return (call-float null args phase))) + + (define (as-float (o object) (c class :unused) (silent boolean :unused)) float32 + (if (in o general-number :narrow-true) + (return (to-float32 o)) + (throw-error -type-error))) + + (define float-prototype simple-instance + (new simple-instance + (%list-set (std-const-binding (new qualified-name public "constructor") -class float)) + -general-number-prototype prototypes-sealed -object + (list-set-of slot) none none none)) (%heading (2 :semantics) "Number") (define -number class (new class - (list-set-of local-binding) -general-number (list-set-of instance-property) (:delay -general-number-prototype) true - "Number" "number" :uninit false true nan64 + (%list-set + (std-const-binding (new qualified-name public "MAX_VALUE") (delay -number) 1.7976931348623157e+308) + (std-const-binding (new qualified-name public "MIN_VALUE") (delay -number) 5e-324) + (std-const-binding (new qualified-name public "NaN") (delay -number) nan64) + (std-const-binding (new qualified-name public "NEGATIVE_INFINITY") (delay -number) -infinity64) + (std-const-binding (new qualified-name public "POSITIVE_INFINITY") (delay -number) +infinity64)) + (list-set-of instance-property) -general-number (delay -number-prototype) true + "Number" "number" :uninit false true nan64 :uninit ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-no-null)) + call-number construct-number none ordinary-is as-number)) + + (define (call-number (this object :unused) (args (vector object)) (phase phase)) float64 + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const arg object (default-arg args 0 +zero64)) + (return (object-to-float64 arg phase))) + + (define (construct-number (args (vector object)) (phase phase)) float64 + (return (call-number null args phase))) + + (define (as-number (o object) (c class :unused) (silent boolean :unused)) float64 + (if (in o general-number :narrow-true) + (return (to-float64 o)) + (throw-error -type-error))) + + (define -number-prototype simple-instance + (new simple-instance + (%list-set + (std-const-binding (new qualified-name public "constructor") -class -number)) + -general-number-prototype prototypes-sealed -object + (list-set-of slot) none none none)) + + (define (make-built-in-integer-class (name string) (low integer) (high integer)) class - (function (call (this object :unused) (args (vector object) :unused) (phase phase :unused)) object - (todo)) - (function (construct (args (vector object) :unused) (phase phase :unused)) object - (todo)) + (function (call (this object :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const arg object (default-arg args 0 +zero64)) + (const x float64 (object-to-float64 arg phase)) + (const i integer-opt (check-integer x)) + (rwhen (and (not-in i (tag none) :narrow-true) (cascade integer low <= i <= high)) + (note (:tag -zero64) " is coerced to " (:tag +zero64) ".") + (return (real-to-float64 i))) + (throw-error -range-error)) + (function (construct (args (vector object)) (phase phase)) object + (return (call null args phase))) (function (is (o object) (c class :unused)) boolean - (if (in o float64 :narrow-true) - (case o - (:select (tag nan64 +infinity64 -infinity64) (return false)) - (:select (tag +zero64 -zero64) (return true)) - (:narrow nonzero-finite-float64 - (const r rational (& value o)) - (return (and (in r integer :narrow-true) (cascade integer low <= r <= high))))) - (return false))) - (function (implicit-coerce (o object) (c class :unused) (silent boolean :unused)) object - (cond - ((in o (tag undefined) :narrow-false) (return +zero64)) - ((in o general-number :narrow-true) - (const i integer-opt (check-integer o)) - (when (and (not-in i (tag none) :narrow-true) (cascade integer low <= i <= high)) - (note (:tag -zero32) ", " (:tag +zero32) ", and " (:tag -zero64) " are all coerced to " (:tag +zero64) ".") - (return (real-to-float64 i))))) - (throw-error -type-error)) + (rwhen (not-in o float64 :narrow-false) + (return false)) + (const i integer-opt (check-integer o)) + (return (and (not-in i (tag none) :narrow-true) (cascade integer low <= i <= high)))) + (function (as (o object) (c class :unused) (silent boolean :unused)) object + (rwhen (not-in o general-number :narrow-false) + (throw-error -type-error)) + (const i integer-opt (check-integer o)) + (rwhen (and (not-in i (tag none) :narrow-true) (cascade integer low <= i <= high)) + (note (:tag -zero32) ", " (:tag +zero32) ", and " (:tag -zero64) " are all coerced to " (:tag +zero64) ".") + (return (real-to-float64 i))) + (throw-error -range-error)) (return (new class - (list-set-of local-binding) -number (list-set-of instance-property) (&opt prototype -number) true - name "number" :uninit false true +zero64 + (%list-set + (std-const-binding (new qualified-name public "MAX_VALUE") -number (real-to-float64 high)) + (std-const-binding (new qualified-name public "MIN_VALUE") -number (real-to-float64 low))) + (list-set-of instance-property) -number (&opt prototype -number) true + name "number" :uninit false true +zero64 :uninit (& bracket-read -number) (& bracket-write -number) (& bracket-delete -number) (& read -number) (& write -number) (& delete -number) (& enumerate -number) - call construct none is implicit-coerce))) + call construct none is as))) (define sbyte class (make-built-in-integer-class "sbyte" -128 127)) (define byte class (make-built-in-integer-class "byte" 0 255)) @@ -5823,45 +6580,433 @@ (define uint class (make-built-in-integer-class "uint" 0 4294967295)) + (%heading (2 :semantics) "Character") (define -character class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -character-prototype) true - "Character" "character" :uninit false true #?0000 + (list-set (std-function (new qualified-name public "fromCharCode") -character_from-char-code 1)) + (list-set-of instance-property) -object (delay -character-prototype) true + "Character" "character" :uninit false true #?0000 :uninit ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-no-null)) + call-character construct-character none ordinary-is as-character)) + + (define (call-character (this object :unused) (args (vector object)) (phase phase)) char16 + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (rwhen (/= (length args) 1) + (throw-error -argument-error "exactly one argument must be supplied")) + (const s string (object-to-string (nth args 0) phase)) + (rwhen (/= (length s) 1) + (throw-error -range-error "only one character may be given")) + (return (nth s 0))) + + (define (construct-character (args (vector object)) (phase phase)) char16 + (if (= (length args) 0) + (return #?0000) + (return (call-character null args phase)))) + + (define (as-character (o object) (c class :unused) (silent boolean :unused)) char16 + (if (in o char16 :narrow-true) + (return o) + (throw-error -type-error))) + + + (define (-character_from-char-code (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if the argument can be converted to a primitive in constant expressions.") + (rwhen (/= (length args) 1) + (throw-error -argument-error "exactly one argument must be supplied")) + (const i extended-integer (object-to-imprecise-integer (nth args 0) phase)) + (if (and (not-in i (tag +infinity -infinity nan) :narrow-true) (cascade integer 0 <= i <= (hex #xFFFF))) + (return (integer-to-char16 i)) + (throw-error -range-error "character code out of range"))) + (define -character-prototype simple-instance (new simple-instance - (list-set-of local-binding) - -object-prototype prototypes-sealed -object + (list-set (std-const-binding (new qualified-name public "constructor") -class -character)) + -string-prototype prototypes-sealed -object (list-set-of slot) none none none)) - ;***** Add some properties here + (%heading (2 :semantics) "String") (define -string class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -string-prototype) true - "String" "string" :uninit false true null - ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + (list-set (std-function (new qualified-name public "fromCharCode") -string_from-char-code 1)) + (list-set-of instance-property string-length-getter) + -object (delay -string-prototype) true + "String" "string" :uninit false true "" :uninit + ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete read-string ordinary-write ordinary-delete ordinary-enumerate + call-string construct-string none ordinary-is as-string)) + + (define (read-string (o object) (limit class) (multiname multiname) (env environment-opt) (phase phase)) + object-opt + (assert (in o string :narrow-true) (:assertion) " because " (:global read-string) " is only called on instances of class " (:character-literal "String") ".") + (when (= limit -string class) + (const i integer-opt (multiname-to-array-index multiname)) + (when (not-in i (tag none) :narrow-true) + (if (< i (length o)) + (return (nth o i)) + (return undefined)))) + (return (ordinary-read o limit multiname env phase))) + + (define (call-string (this object :unused) (args (vector object)) (phase phase)) string + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (return (object-to-string (default-arg args 0 "") phase))) + + (define (construct-string (args (vector object)) (phase phase)) string + (return (call-string null args phase))) + + (define (as-string (o object) (c class :unused) (silent boolean :unused)) string + (if (in o (union char16 string) :narrow-true) + (return (to-string o)) + (throw-error -type-error))) + + + (define string-length-getter instance-getter (new instance-getter (list-set (new qualified-name public "length")) true false :uninit -string_length)) + (define (-string_length (this object) (phase phase :unused)) object + (assert (in this string :narrow-true) (:assertion) " because this getter cannot be extracted from the " (:character-literal "String") " class.") + (const length integer (length this)) + (return (real-to-float64 length))) + + + (define (-string_from-char-code (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if the arguments can be converted to primitives in constant expressions.") + (var s string "") + (for-each args arg + (const i extended-integer (object-to-imprecise-integer arg phase)) + (if (and (not-in i (tag +infinity -infinity nan) :narrow-true) (cascade integer 0 <= i <= (hex #x10FFFF))) + (<- s (append s (integer-to-u-t-f16 i))) + (throw-error -range-error "character code out of range"))) + (return s)) + (define -string-prototype simple-instance (new simple-instance - (list-set-of local-binding) + (%list-set + (std-const-binding (new qualified-name public "constructor") -class -string) + (std-function (new qualified-name public "toString") -string_to-string 0) + (std-function (new qualified-name public "charAt") -string_char-at 1) + (std-function (new qualified-name public "charCodeAt") -string_char-code-at 1) + (std-function (new qualified-name public "concat") -string_concat 1) + (std-function (new qualified-name public "indexOf") -string_index-of 1) + (std-function (new qualified-name public "lastIndexOf") -string_last-index-of 1) + (std-function (new qualified-name public "localeCompare") -string_locale-compare 1) + (std-function (new qualified-name public "match") -string_match 1) + (std-function (new qualified-name public "replace") -string_replace 1) + (std-function (new qualified-name public "search") -string_search 1) + (std-function (new qualified-name public "slice") -string_slice 2) + (std-function (new qualified-name public "split") -string_split 2) + (std-function (new qualified-name public "substring") -string_substring 2) + (std-function (new qualified-name public "toLowerCase") -string_to-lower-case 0) + (std-function (new qualified-name public "toLocaleLowerCase") -string_to-locale-lower-case 0) + (std-function (new qualified-name public "toUpperCase") -string_to-upper-case 0) + (std-function (new qualified-name public "toLocaleUpperCase") -string_to-locale-upper-case 0)) -object-prototype prototypes-sealed -object (list-set-of slot) none none none)) - ;***** Add some properties here + + + (define (-string_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (note "This function ignores any arguments passed to it in " (:local args) ".") + (return (object-to-string this phase))) + + + (define (-string_char-at (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the argument can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const s string (object-to-string this phase)) + (var position extended-integer (object-to-imprecise-integer (default-arg args 0 +zero64) phase)) + (when (in position (tag nan)) + (<- position 0)) + (quiet-assert (not-in position (tag nan) :narrow-true)) + (if (and (not-in position (tag +infinity -infinity) :narrow-true) (cascade integer 0 <= position < (length s))) + (return (vector (nth s position))) + (return ""))) + + + (define (-string_char-code-at (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the argument can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const s string (object-to-string this phase)) + (var position extended-integer (object-to-imprecise-integer (default-arg args 0 +zero64) phase)) + (when (in position (tag nan)) + (<- position 0)) + (quiet-assert (not-in position (tag nan) :narrow-true)) + (if (and (not-in position (tag +infinity -infinity) :narrow-true) (cascade integer 0 <= position < (length s))) + (return (real-to-float64 (char16-to-integer (nth s position)))) + (return nan64))) + + + (define (-string_concat (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the argument can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (var s string (object-to-string this phase)) + (for-each args arg + (<- s (append s (object-to-string arg phase)))) + (return s)) + + + (define (-string_index-of (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the arguments can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (set-not-in (length args) (range-set-of integer 1 2)) + (throw-error -argument-error "at least one and at most two arguments must be supplied")) + (const s string (object-to-string this phase)) + (const pattern string (object-to-string (nth args 0) phase)) + (var position extended-integer (object-to-imprecise-integer (default-arg args 1 +zero64) phase)) + (cond + ((in position (tag -infinity nan) :narrow-false) + (<- position 0)) + ((or (in position (tag +infinity) :narrow-false) (> position (length s))) + (<- position (length s))) + ((< position 0) + (<- position 0))) + (quiet-assert (not-in position (tag +infinity -infinity nan) :narrow-true)) + (while (<= (+ position (length pattern)) (length s)) + (rwhen (= (subseq s position (+ position (- (length pattern) 1))) pattern string) + (return (real-to-float64 position))) + (<- position (+ position 1))) + (return -1.0)) + + + (define (-string_last-index-of (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the arguments can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (set-not-in (length args) (range-set-of integer 1 2)) + (throw-error -argument-error "at least one and at most two arguments must be supplied")) + (const s string (object-to-string this phase)) + (const pattern string (object-to-string (nth args 0) phase)) + (var position extended-integer (object-to-imprecise-integer (default-arg args 1 +infinity64) phase)) + (cond + ((in position (tag -infinity) :narrow-false) + (<- position 0)) + ((or (in position (tag +infinity nan) :narrow-false) (> position (length s))) + (<- position (length s))) + ((< position 0) + (<- position 0))) + (quiet-assert (not-in position (tag +infinity -infinity nan) :narrow-true)) + (when (> (+ position (length pattern)) (length s)) + (<- position (- (length s) (length pattern)))) + (while (>= position 0) + (rwhen (= (subseq s position (+ position (- (length pattern) 1))) pattern string) + (return (real-to-float64 position))) + (<- position (- position 1))) + (return -1.0)) + + + (define (-string_locale-compare (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "localeCompare") " cannot be called from constant expressions")) + (rwhen (< (length args) 1) + (throw-error -argument-error "at least one argument must be supplied")) + (const s1 string (object-to-string this phase)) + (const s2 string (object-to-string (nth args 0) phase)) + (/* "Let " (:local result) ":" :nbsp (:type object) " be a value of type " (:global -number) " that is the result of a locale-sensitive string comparison of " + (:local s1) " and " (:local s2) ". The two strings are compared in an implementation-defined fashion. The result is intended to order string in the sort order " + "specified by the system default locale, and will be negative, zero, or positive, depending on whether " (:local s1) " comes before " (:local s2) + " in the sort order, the strings are equal, or " (:local s1) " comes after " (:local s2) " in the sort order, respectively. The result shall not be " + (:tag nan64) ". The comparison shall be a consistent comparison function on the set of all strings.") + (var result object) + (cond + ((< s1 s2 string) (<- result -1.0)) + ((> s1 s2 string) (<- result +1.0)) + (nil (<- result +zero64))) + (*/) + (return result)) + + + (define (-string_match (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "match") " cannot be called from constant expressions")) + (rwhen (/= (length args) 1) + (throw-error -argument-error "exactly one argument must be supplied")) + (const s string (object-to-string this phase)) + (todo)) + + + (define (-string_replace (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "replace") " cannot be called from constant expressions")) + (rwhen (/= (length args) 2) + (throw-error -argument-error "exactly two arguments must be supplied")) + (const s string (object-to-string this phase)) + (todo)) + + + (define (-string_search (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "search") " cannot be called from constant expressions")) + (rwhen (/= (length args) 1) + (throw-error -argument-error "exactly one argument must be supplied")) + (const s string (object-to-string this phase)) + (todo)) + + + (define (-string_slice (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the arguments can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (> (length args) 2) + (throw-error -argument-error "at most two arguments can be supplied")) + (const s string (object-to-string this phase)) + (var start extended-integer (object-to-imprecise-integer (default-arg args 0 +zero64) phase)) + (var end extended-integer (object-to-imprecise-integer (default-arg args 0 +infinity64) phase)) + (cond + ((in start (tag -infinity nan) :narrow-false) + (<- start 0)) + ((or (in start (tag +infinity) :narrow-false) (> start (length s))) + (<- start (length s))) + ((< start 0) + (<- start (+ start (length s))) + (when (< start 0) + (<- start 0)))) + (quiet-assert (not-in start (tag +infinity -infinity nan) :narrow-true)) + (cond + ((in end (tag -infinity) :narrow-false) + (<- end 0)) + ((or (in end (tag +infinity nan) :narrow-false) (> end (length s))) + (<- end (length s))) + ((< end 0) + (<- end (+ end (length s))) + (when (< end 0) + (<- end 0)))) + (quiet-assert (not-in end (tag +infinity -infinity nan) :narrow-true)) + (if (< start end) + (return (subseq s start (- end 1))) + (return ""))) + + + (define (-string_split (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "split") " cannot be called from constant expressions")) + (rwhen (> (length args) 2) + (throw-error -argument-error "at most two arguments can be supplied")) + (const s string (object-to-string this phase)) + (todo)) + + + (define (-string_substring (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " and the arguments can be converted to primitives in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (> (length args) 2) + (throw-error -argument-error "at most two arguments can be supplied")) + (const s string (object-to-string this phase)) + (var start extended-integer (object-to-imprecise-integer (default-arg args 0 +zero64) phase)) + (var end extended-integer (object-to-imprecise-integer (default-arg args 0 +infinity64) phase)) + (cond + ((in start (tag -infinity nan) :narrow-false) + (<- start 0)) + ((or (in start (tag +infinity) :narrow-false) (> start (length s))) + (<- start (length s))) + ((< start 0) + (<- start 0))) + (quiet-assert (not-in start (tag +infinity -infinity nan) :narrow-true)) + (cond + ((in end (tag -infinity) :narrow-false) + (<- end 0)) + ((or (in end (tag +infinity nan) :narrow-false) (> end (length s))) + (<- end (length s))) + ((< end 0) + (<- end 0))) + (quiet-assert (not-in end (tag +infinity -infinity nan) :narrow-true)) + (if (<= start end) + (return (subseq s start (- end 1))) + (return (subseq s end (- start 1))))) + + + (define (-string_to-lower-case (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (const s string (object-to-string this phase)) + (var r string "") + (for-each s ch + (<- r (append r (char-to-lower-full ch)))) + (return r)) + + + (define (-string_to-locale-lower-case (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) object + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "toLocaleLowerCase") " cannot be called from constant expressions")) + (const s string (object-to-string this phase)) + (var r string "") + (for-each s ch + (<- r (append r (char-to-lower-localized ch)))) + (return r)) + + + (define (-string_to-upper-case (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) object + (note "This function can be used in constant expressions if " (:local this) " can be converted to a primitive in constant expressions.") + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (const s string (object-to-string this phase)) + (var r string "") + (for-each s ch + (<- r (append r (char-to-upper-full ch)))) + (return r)) + + + (define (-string_to-locale-upper-case (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) object + (note "This function is generic and can be applied even if " (:local this) " is not a string.") + (rwhen (in phase (tag compile)) + (throw-error -constant-error (:character-literal "toLocaleUpperCase") " cannot be called from constant expressions")) + (const s string (object-to-string this phase)) + (var r string "") + (for-each s ch + (<- r (append r (char-to-upper-localized ch)))) + (return r)) + (%heading (2 :semantics) "Array") (define -array class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -array-prototype) true - "Array" "object" array-private true true null - ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read array-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + (list-set-of local-binding) (list-set-of instance-property) -object (delay -array-prototype) true + "Array" "object" array-private true true null hint-number + ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read write-array ordinary-delete ordinary-enumerate + dummy-call dummy-construct none ordinary-is ordinary-as)) + + (define array-limit integer (- (expt 2 64) 1)) + (define array-private namespace (new namespace "private")) + + (define (write-array (o object) (limit class) (multiname multiname) (env environment-opt) (create-if-missing boolean) (new-value object) (phase (tag run))) + (tag none ok) + (const result (tag none ok) (ordinary-write o limit multiname env create-if-missing new-value phase)) + (when (in result (tag ok)) + (const i integer-opt (multiname-to-array-index multiname)) + (when (not-in i (tag none) :narrow-true) + (var length u-long (assert-in (read-instance-slot o (new qualified-name array-private "length") phase) u-long)) + (when (>= i (& value length)) + (<- length (new u-long (+ i 1))) + (dot-write o (list-set (new qualified-name array-private "length")) length phase)))) + (return result)) + + (define (multiname-to-array-index (multiname multiname)) integer-opt + (rwhen (/= (length multiname) 1) + (return none)) + (const qname qualified-name (unique-elt-of multiname)) + (rwhen (/= (& namespace qname) public namespace) + (return none)) + (const name string (& id qname)) + (when (nonempty name) + (cond + ((= name "0" string) (return 0)) + ((and (/= (nth name 0) #\0 char16) (every name ch (set-in ch (range-set-of-ranges char16 #\0 #\9)))) + (const i integer (assert-not-in (string-to-integer name 10) (tag none))) + (rwhen (< i array-limit) + (return i))))) + (return none)) + (define -array-prototype simple-instance (new simple-instance @@ -5871,50 +7016,80 @@ ;***** Add some properties here - (define array-limit integer (- (expt 2 64) 1)) - (define array-private namespace (new namespace "private")) - - (define (array-write (o object) (limit class) (multiname multiname) (env environment-opt) (create-if-missing boolean) (new-value object) (phase (tag run))) - (tag none ok) - (const result (tag none ok) (ordinary-write o limit multiname env create-if-missing new-value phase)) - (when (and (in result (tag ok)) (= (length multiname) 1)) - (const qname qualified-name (unique-elt-of multiname)) - (when (= (& namespace qname) public namespace) - (const name string (& id qname)) - (const i integer (truncate-to-integer (to-general-number name phase))) ;***** Use a more specific conversion here? - (when (and (= name (integer-to-string i) string) (cascade integer 0 <= i < array-limit)) - (var length u-long (assert-in (read-instance-slot o (new qualified-name array-private "length") phase) u-long)) - (when (>= i (& value length)) - (<- length (new u-long (+ i 1))) - (dot-write o (list-set (new qualified-name array-private "length")) length phase))))) - (return result)) - (%heading (2 :semantics) "Namespace") (define -namespace class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -object-prototype) true - "Namespace" "namespace" :uninit false true null + (list-set-of local-binding) (list-set-of instance-property) -object (delay -namespace-prototype) true + "Namespace" "namespace" :uninit false true null hint-string ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) + + (define (call-namespace (this object :unused) (args (vector object)) (phase phase)) (union namespace null) + (note "This function can be used in constant expressions.") + (rwhen (/= (length args) 1) + (throw-error -argument-error "exactly one argument must be supplied")) + (const arg object (nth args 0)) + (if (in arg (union namespace null) :narrow-true) + (return arg) + (throw-error -type-error))) + + (define (construct-namespace (args (vector object)) (phase phase)) namespace + (note "This function can be used in constant expressions if its argument is a string.") + (rwhen (> (length args) 1) + (throw-error -argument-error "at most one argument can be supplied")) + (const arg object (default-arg args 0 undefined)) + (cond + ((in arg (union null undefined)) + (rwhen (in phase (tag compile)) + (throw-error -constant-error "constant expressions cannot construct new anonymous namespaces")) + (return (new namespace "anonymous"))) + ((in arg (union char16 string) :narrow-true) + (const name string (to-string arg)) + (cond + ((= name "" string) + (return public)) + (nil + (/* (:keyword return) " a namespace generated from the URI in " (:local name) " in an implementation-defined manner. " + "Constructing a namespace twice using the same " (:local name) " shall return the same namespace. Constructing namespaces using different values of " + (:local name) " may or may not return the same namespace, depending on whether the implementation considers the differences in the names to be significant. " + "Constructing a namespace from " (:local name) " shall not return any of the private or internal namespaces that are constructed elsewhere in this specification.") + (return uri-namespace)))) + (nil (throw-error -type-error)))) + + (define uri-namespace namespace (new namespace "URI Namespace")) ;***** + + (define -namespace-prototype simple-instance + (new simple-instance + (%list-set (std-function (new qualified-name public "toString") -namespace_to-string 0)) + -object-prototype prototypes-sealed -object + (list-set-of slot) none none none)) + + + (define (-namespace_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string + (note "This function can be used in constant expressions.") + (note "This function ignores any arguments passed to it in " (:local args) ".") + (rwhen (not-in this namespace :narrow-false) + (throw-error -type-error)) + (return (& name this))) (%heading (2 :semantics) "Attribute") (define -attribute class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -object-prototype) true - "Attribute" "object" :uninit false true null + (list-set-of local-binding) (list-set-of instance-property) -object (delay -object-prototype) true + "Attribute" "object" :uninit false true null hint-string ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (%heading (2 :semantics) "Date") (define -date class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -date-prototype) true - "Date" "object" :uninit true true null + (list-set-of local-binding) (list-set-of instance-property) -object (delay -date-prototype) true + "Date" "object" :uninit true true null hint-string ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -date-prototype simple-instance (new simple-instance @@ -5927,10 +7102,10 @@ (%heading (2 :semantics) "RegExp") (define -reg-exp class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -reg-exp-prototype) true - "RegExp" "object" :uninit true true null + (list-set-of local-binding) (list-set-of instance-property) -object (delay -reg-exp-prototype) true + "RegExp" "object" :uninit true true null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -reg-exp-prototype simple-instance (new simple-instance @@ -5943,22 +7118,40 @@ (%heading (2 :semantics) "Class") (define -class class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -object-prototype) true - "Class" "function" :uninit false true null + (list-set-of local-binding) + (list-set-of instance-property class-prototype-getter) + -object (delay -class-prototype) true + "Class" "function" :uninit false true null hint-string ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) + + (define class-prototype-getter instance-getter (new instance-getter (list-set (new qualified-name public "prototype")) true false :uninit -class_prototype)) + (define (-class_prototype (this object) (phase phase :unused)) object + (assert (in this class :narrow-true) (:assertion) " because this getter cannot be extracted from the " (:character-literal "Class") " class.") + (const prototype object-opt (&opt prototype this)) + (if (in prototype (tag none) :narrow-false) + (return undefined) + (return prototype))) + + (define -class-prototype simple-instance + (new simple-instance + (list-set-of local-binding) + -object-prototype prototypes-sealed -object + (list-set-of slot) none none none)) + ;***** Add some properties here (%heading (2 :semantics) "Function") (define -function class (new class - (list-set-of local-binding) -object - (list-set-of instance-property - (new instance-variable (list-set (new qualified-name public "length")) true false -number none true)) - (:delay -function-prototype) true - "Function" "function" :uninit false true null + (list-set-of local-binding) + (list-set-of instance-property ivar-function-length) + -object (delay -function-prototype) true + "Function" "function" :uninit false true null hint-string ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) + + (define ivar-function-length instance-variable (new instance-variable (list-set (new qualified-name public "length")) true false -number none true)) (define -function-prototype simple-instance (new simple-instance @@ -5967,46 +7160,36 @@ (list-set-of slot) none none none)) ;***** Add some properties here - (define (system-function (call (union (-> (object simple-instance (vector object) phase) object) (tag none))) - (length integer)) - simple-instance - (const v-length instance-variable (assert-in (find-local-instance-property -function (list-set (new qualified-name public "length")) read-write) instance-variable)) - (return (new simple-instance - (list-set-of local-binding) (&opt prototype -function) true -function - (list-set (new slot v-length (real-to-float64 length))) - call none none))) - (%heading (3 :semantics) "PrototypeFunction") (define -prototype-function class (new class - (list-set-of local-binding) -function + (list-set-of local-binding) (list-set-of instance-property (new instance-variable (list-set (new qualified-name public "prototype")) true false -object undefined false)) - (:delay -function-prototype) true - "Function" "function" :uninit true true null + -function (delay -function-prototype) true + "Function" "function" :uninit true true null hint-string ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) ;***** Need to set prototype here. + dummy-call dummy-construct none ordinary-is ordinary-as)) ;***** Need to set prototype here. (%heading (2 :semantics) "Package") (define -package class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -object-prototype) true - "Package" "object" :uninit true true null + (list-set-of local-binding) (list-set-of instance-property) -object (delay -object-prototype) true + "Package" "object" :uninit true true null hint-string ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (%heading (2 :semantics) "Error") (define -error class (new class - (list-set-of local-binding) -object (list-set-of instance-property) (:delay -error-prototype) true - "Error" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -object (delay -error-prototype) true + "Error" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) - ;(define (call-error ( (define -error-prototype simple-instance (new simple-instance @@ -6023,10 +7206,10 @@ (%heading (3 :semantics) "ArgumentError") (define -argument-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -argument-error-prototype) true - "ArgumentError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -argument-error-prototype) true + "ArgumentError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -argument-error-prototype simple-instance (new simple-instance @@ -6039,10 +7222,10 @@ (%heading (3 :semantics) "AttributeError") (define -attribute-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -attribute-error-prototype) true - "AttributeError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -attribute-error-prototype) true + "AttributeError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -attribute-error-prototype simple-instance (new simple-instance @@ -6055,10 +7238,10 @@ (%heading (3 :semantics) "ConstantError") (define -constant-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -constant-error-prototype) true - "ConstantError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -constant-error-prototype) true + "ConstantError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -constant-error-prototype simple-instance (new simple-instance @@ -6071,10 +7254,10 @@ (%heading (3 :semantics) "DefinitionError") (define -definition-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -definition-error-prototype) true - "DefinitionError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -definition-error-prototype) true + "DefinitionError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -definition-error-prototype simple-instance (new simple-instance @@ -6087,10 +7270,10 @@ (%heading (3 :semantics) "EvalError") (define -eval-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -eval-error-prototype) true - "EvalError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -eval-error-prototype) true + "EvalError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -eval-error-prototype simple-instance (new simple-instance @@ -6103,10 +7286,10 @@ (%heading (3 :semantics) "RangeError") (define -range-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -range-error-prototype) true - "RangeError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -range-error-prototype) true + "RangeError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -range-error-prototype simple-instance (new simple-instance @@ -6119,10 +7302,10 @@ (%heading (3 :semantics) "ReferenceError") (define -reference-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -reference-error-prototype) true - "ReferenceError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -reference-error-prototype) true + "ReferenceError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -reference-error-prototype simple-instance (new simple-instance @@ -6135,10 +7318,10 @@ (%heading (3 :semantics) "SyntaxError") (define -syntax-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -syntax-error-prototype) true - "SyntaxError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -syntax-error-prototype) true + "SyntaxError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -syntax-error-prototype simple-instance (new simple-instance @@ -6151,10 +7334,10 @@ (%heading (3 :semantics) "TypeError") (define -type-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -type-error-prototype) true - "TypeError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -type-error-prototype) true + "TypeError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -type-error-prototype simple-instance (new simple-instance @@ -6167,10 +7350,10 @@ (%heading (3 :semantics) "UninitializedError") (define -uninitialized-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -uninitialized-error-prototype) true - "UninitializedError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -uninitialized-error-prototype) true + "UninitializedError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -uninitialized-error-prototype simple-instance (new simple-instance @@ -6183,10 +7366,10 @@ (%heading (3 :semantics) "URIError") (define -u-r-i-error class (new class - (list-set-of local-binding) -error (list-set-of instance-property) (:delay -u-r-i-error-prototype) true - "URIError" "object" :uninit true false null + (list-set-of local-binding) (list-set-of instance-property) -error (delay -u-r-i-error-prototype) true + "URIError" "object" :uninit true false null hint-number ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate - dummy-call dummy-construct none ordinary-is ordinary-implicit-coerce-null)) + dummy-call dummy-construct none ordinary-is ordinary-as)) (define -u-r-i-error-prototype simple-instance (new simple-instance