зеркало из https://github.com/mozilla/pjs.git
8254 строки
469 KiB
Common Lisp
8254 строки
469 KiB
Common Lisp
;;;
|
|
;;; JavaScript 2.0 parser
|
|
;;;
|
|
;;; Waldemar Horwat (waldemar@acm.org)
|
|
;;;
|
|
|
|
(declaim (optimize (debug 3)))
|
|
|
|
(defparameter *jw-source*
|
|
'((line-grammar code-grammar :lr-1 :program)
|
|
|
|
(%heading (1 :semantics) "Data Model")
|
|
(%heading (2 :semantics) "Semantic Exceptions")
|
|
|
|
(deftuple break (value object) (label label))
|
|
(deftuple continue (value object) (label label))
|
|
(deftuple return (value object))
|
|
|
|
(deftype control-transfer (union break continue return))
|
|
(deftype semantic-exception (union object control-transfer))
|
|
|
|
(%heading (2 :semantics) "Extended integers and rationals")
|
|
|
|
(deftag +zero)
|
|
(deftag -zero)
|
|
(deftag +infinity)
|
|
(deftag -infinity)
|
|
(deftag nan)
|
|
(deftype extended-rational (union (exclude-zero rational) (tag +zero -zero +infinity -infinity nan)))
|
|
(deftype extended-integer (union integer (tag +infinity -infinity nan)))
|
|
(? hide
|
|
(deftag syntax-error))
|
|
|
|
|
|
(%heading (2 :semantics) "Objects")
|
|
(deftag none)
|
|
(deftag ok)
|
|
(deftag reject)
|
|
|
|
(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)))
|
|
(deftype boolean-opt (union boolean (tag none)))
|
|
(deftype integer-opt (union integer (tag none)))
|
|
|
|
|
|
(%heading (3 :semantics) "Undefined")
|
|
(deftag undefined)
|
|
(deftype undefined (tag undefined))
|
|
|
|
|
|
(%heading (3 :semantics) "Null")
|
|
(deftag null)
|
|
(deftype null (tag null))
|
|
|
|
|
|
(%heading (3 :semantics) "Strings")
|
|
(deftype string-opt (union string (tag none)))
|
|
|
|
|
|
(%heading (3 :semantics) "Namespaces")
|
|
(defrecord namespace
|
|
(name string))
|
|
|
|
|
|
(%heading (4 :semantics) "Qualified Names")
|
|
(deftuple qualified-name (namespace namespace) (id string))
|
|
(definfix qualified-name ("::") ns id)
|
|
|
|
(deftype multiname (list-set qualified-name))
|
|
|
|
|
|
(%heading (3 :semantics) "Attributes")
|
|
(deftag static)
|
|
(deftag virtual)
|
|
(deftag final)
|
|
(deftype property-category (tag none static virtual final))
|
|
|
|
(deftype override-modifier (tag none true false undefined))
|
|
|
|
(deftuple compound-attribute
|
|
(namespaces (list-set namespace))
|
|
(explicit boolean)
|
|
(enumerable boolean)
|
|
(dynamic boolean)
|
|
(category property-category)
|
|
(override-mod override-modifier)
|
|
(prototype boolean)
|
|
(unused boolean))
|
|
|
|
(deftype attribute (union boolean namespace compound-attribute))
|
|
(deftype attribute-opt-not-false (union (tag none true) namespace compound-attribute))
|
|
|
|
|
|
(%heading (3 :semantics) "Classes")
|
|
(defrecord class
|
|
(local-bindings (list-set local-binding) :var)
|
|
(instance-properties (list-set instance-property) :var)
|
|
(super class-opt)
|
|
(prototype object-opt :opt-const)
|
|
(complete boolean :var)
|
|
(name string)
|
|
(typeof-string string)
|
|
(private-namespace namespace :opt-const)
|
|
(dynamic boolean)
|
|
(final boolean)
|
|
(default-value object-opt)
|
|
(default-hint hint :opt-const)
|
|
(has-property (-> (object class object boolean phase) boolean))
|
|
(bracket-read (-> (object class (vector object) boolean phase) object-opt))
|
|
(bracket-write (-> (object class (vector object) object boolean (tag run)) (tag none ok)))
|
|
(bracket-delete (-> (object class (vector object) (tag run)) boolean-opt))
|
|
(read (-> (object class multiname environment-opt boolean phase) object-opt))
|
|
(write (-> (object class multiname environment-opt object boolean (tag run)) (tag none ok)))
|
|
(delete (-> (object class multiname environment-opt (tag run)) boolean-opt))
|
|
(enumerate (-> (object) (list-set object)))
|
|
(call (-> (object class (vector object) phase) object))
|
|
(construct (-> (class (vector object) phase) object))
|
|
(init (union (-> (simple-instance (vector object) (tag run)) void) (tag none)) :var)
|
|
(is (-> (object class) boolean))
|
|
(coerce (-> (object class) object-opt)))
|
|
(deftype class-opt (union class (tag none)))
|
|
|
|
|
|
(%heading (3 :semantics) "Simple Instances")
|
|
(defrecord simple-instance
|
|
(local-bindings (list-set local-binding) :var)
|
|
(archetype object-opt :opt-const)
|
|
(sealed boolean :var)
|
|
(type class)
|
|
(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))
|
|
|
|
|
|
(%heading (4 :semantics) "Slots")
|
|
(defrecord slot
|
|
(id instance-variable)
|
|
(value object-opt :var))
|
|
|
|
|
|
(%heading (3 :semantics) "Uninstantiated Functions")
|
|
(defrecord uninstantiated-function
|
|
(type class)
|
|
(length integer)
|
|
(call (union (-> (object simple-instance (vector object) phase) object) (tag none)))
|
|
(construct (union (-> (simple-instance (vector object) phase) object) (tag none)))
|
|
(instantiations (list-set simple-instance) :var))
|
|
|
|
|
|
(%heading (3 :semantics) "Method Closures")
|
|
(deftuple method-closure
|
|
(this object)
|
|
(method instance-method)
|
|
(slots (list-set slot)))
|
|
|
|
|
|
(%heading (3 :semantics) "Dates")
|
|
(defrecord date
|
|
(local-bindings (list-set local-binding) :var)
|
|
(archetype object-opt)
|
|
(sealed boolean :var)
|
|
(time-value integer))
|
|
|
|
|
|
(%heading (3 :semantics) "Regular Expressions")
|
|
(defrecord reg-exp
|
|
(local-bindings (list-set local-binding) :var)
|
|
(archetype object-opt)
|
|
(sealed boolean :var)
|
|
(source string)
|
|
(last-index integer)
|
|
(global boolean)
|
|
(ignore-case boolean)
|
|
(multiline boolean))
|
|
|
|
|
|
(%heading (3 :semantics) "Packages")
|
|
(defrecord package
|
|
(local-bindings (list-set local-binding) :var)
|
|
(archetype object-opt)
|
|
(name string)
|
|
(initialize (union (-> () void) (tag none busy)) :var)
|
|
(sealed boolean :var)
|
|
(internal-namespace namespace))
|
|
|
|
|
|
(%heading (2 :semantics) "Objects with Limits")
|
|
(%text :comment (:label limited-instance instance) " must be an instance of one of "
|
|
(:label limited-instance limit) :apostrophe "s descendants.")
|
|
(deftuple limited-instance
|
|
(instance object)
|
|
(limit class))
|
|
|
|
(deftype obj-optional-limit (union object limited-instance))
|
|
|
|
|
|
(%heading (2 :semantics) "References")
|
|
(deftuple lexical-reference
|
|
(env environment)
|
|
(variable-multiname multiname)
|
|
(strict boolean))
|
|
|
|
(deftuple dot-reference
|
|
(base object)
|
|
(limit class)
|
|
(multiname multiname))
|
|
|
|
(deftuple bracket-reference
|
|
(base object)
|
|
(limit class)
|
|
(args (vector object)))
|
|
|
|
(deftype reference (union lexical-reference dot-reference bracket-reference))
|
|
(deftype obj-or-ref (union object reference))
|
|
|
|
|
|
(%heading (2 :semantics) "Modes of expression evaluation")
|
|
(deftag compile)
|
|
(deftag run)
|
|
(deftype phase (tag compile run))
|
|
|
|
|
|
(%heading (2 :semantics) "Contexts")
|
|
(defrecord context
|
|
(strict boolean :var)
|
|
(open-namespaces (list-set namespace) :var))
|
|
|
|
|
|
(%heading (2 :semantics) "Labels")
|
|
(deftag default)
|
|
(deftype label (union string (tag default)))
|
|
|
|
(deftuple jump-targets
|
|
(break-targets (list-set label))
|
|
(continue-targets (list-set label)))
|
|
|
|
|
|
(%heading (2 :semantics) "Function Support")
|
|
(deftag normal)
|
|
(deftag get)
|
|
(deftag set)
|
|
(deftype handling (tag normal get set))
|
|
|
|
(deftag plain-function)
|
|
(deftag unchecked-function)
|
|
(deftag prototype-function)
|
|
(deftag instance-function)
|
|
(deftag constructor-function)
|
|
(deftype static-function-kind (tag plain-function unchecked-function prototype-function))
|
|
(deftype function-kind (tag plain-function unchecked-function prototype-function instance-function constructor-function))
|
|
|
|
|
|
(%heading (2 :semantics) "Environments")
|
|
(%text :comment "An " (:type environment) " is a list of two or more frames. Each frame corresponds to a scope. "
|
|
"More specific frames are listed first" :m-dash "each frame" :apostrophe "s scope is directly contained in the following frame"
|
|
:apostrophe "s scope. The last frame is always a " (:type package)
|
|
". A " (:type with-frame) " is always preceded by a " (:type local-frame) ", so the first frame is never a " (:type with-frame) ".")
|
|
(deftype environment (vector frame))
|
|
(deftype environment-opt (union environment (tag none)))
|
|
(deftype frame (union non-with-frame with-frame))
|
|
(deftype non-with-frame (union package parameter-frame class local-frame))
|
|
|
|
(defrecord parameter-frame
|
|
(local-bindings (list-set local-binding) :var)
|
|
(kind function-kind)
|
|
(handling handling)
|
|
(calls-superconstructor boolean :var)
|
|
(superconstructor-called boolean :var)
|
|
(this object-opt)
|
|
(parameters (vector parameter) :opt-var)
|
|
(rest variable-opt :opt-var)
|
|
(return-type class :opt-const))
|
|
(deftype parameter-frame-opt (union parameter-frame (tag none)))
|
|
|
|
(deftuple parameter
|
|
(var (union variable dynamic-var))
|
|
(default object-opt))
|
|
|
|
(defrecord local-frame
|
|
(local-bindings (list-set local-binding) :var))
|
|
|
|
(defrecord with-frame
|
|
(value object-opt))
|
|
|
|
|
|
(%heading (3 :semantics) "Properties")
|
|
(deftag read)
|
|
(deftag write)
|
|
(deftag read-write)
|
|
(deftype access (tag read write))
|
|
(deftype access-set (tag read write read-write))
|
|
|
|
|
|
(deftuple local-binding
|
|
(qname qualified-name)
|
|
(accesses access-set)
|
|
(explicit boolean)
|
|
(enumerable boolean)
|
|
(content singleton-property))
|
|
|
|
|
|
(deftag forbidden)
|
|
(deftype singleton-property (union (tag forbidden) variable dynamic-var getter setter))
|
|
(deftype singleton-property-opt (union singleton-property (tag none)))
|
|
|
|
(deftype variable-value (union (tag none) object uninstantiated-function))
|
|
|
|
(deftag busy)
|
|
(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)
|
|
(initializer (union initializer (tag none busy)) :var)
|
|
(initializer-env environment :opt-const))
|
|
(deftype variable-opt (union variable (tag none)))
|
|
|
|
(defrecord dynamic-var
|
|
(value (union object uninstantiated-function) :var)
|
|
(sealed boolean :var))
|
|
|
|
(defrecord getter
|
|
(call (-> (environment phase) object))
|
|
(env environment-opt))
|
|
|
|
(defrecord setter
|
|
(call (-> (object environment phase) void))
|
|
(env environment-opt))
|
|
|
|
|
|
(deftype instance-property (union instance-variable instance-method instance-getter instance-setter))
|
|
(deftype instance-property-opt (union instance-property (tag none)))
|
|
|
|
(defrecord instance-variable
|
|
(multiname multiname :opt-const)
|
|
(final boolean)
|
|
(enumerable boolean :opt-const)
|
|
(type class :opt-const)
|
|
(default-value object-opt :opt-const)
|
|
(immutable boolean))
|
|
(deftype instance-variable-opt (union instance-variable (tag none)))
|
|
|
|
(defrecord instance-method
|
|
(multiname multiname :opt-const)
|
|
(final boolean)
|
|
(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 :opt-const)
|
|
(signature parameter-frame :opt-const)
|
|
(call (-> (object phase) object)))
|
|
|
|
(defrecord instance-setter
|
|
(multiname multiname :opt-const)
|
|
(final boolean)
|
|
(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")
|
|
|
|
(%text :comment (:global-call unsigned-wrap32 i) " returns " (:local i) " converted to a value between 0 and 2" (:superscript "32") :minus
|
|
"1 inclusive, wrapping around modulo 2" (:superscript "32") " if necessary.")
|
|
(define (unsigned-wrap32 (i integer)) (integer-range 0 (- (expt 2 32) 1))
|
|
(return (bitwise-and i (hex #xFFFFFFFF))))
|
|
|
|
(%text :comment (:global-call signed-wrap32 i) " returns " (:local i) " converted to a value between " :minus "2" (:superscript "31")
|
|
" and 2" (:superscript "31") :minus "1 inclusive, wrapping around modulo 2" (:superscript "32") " if necessary.")
|
|
(define (signed-wrap32 (i integer)) (integer-range (neg (expt 2 31)) (- (expt 2 31) 1))
|
|
(var j integer (bitwise-and i (hex #xFFFFFFFF)))
|
|
(when (>= j (expt 2 31))
|
|
(<- j (- j (expt 2 32))))
|
|
(return j))
|
|
|
|
(%text :comment (:global-call unsigned-wrap64 i) " returns " (:local i) " converted to a value between 0 and 2" (:superscript "64") :minus
|
|
"1 inclusive, wrapping around modulo 2" (:superscript "64") " if necessary.")
|
|
(define (unsigned-wrap64 (i integer)) (integer-range 0 (- (expt 2 64) 1))
|
|
(return (bitwise-and i (hex #xFFFFFFFFFFFFFFFF))))
|
|
|
|
(%text :comment (:global-call signed-wrap64 i) " returns " (:local i) " converted to a value between " :minus "2" (:superscript "63")
|
|
" and 2" (:superscript "63") :minus "1 inclusive, wrapping around modulo 2" (:superscript "64") " if necessary.")
|
|
(define (signed-wrap64 (i integer)) (integer-range (neg (expt 2 63)) (- (expt 2 63) 1))
|
|
(var j integer (bitwise-and i (hex #xFFFFFFFFFFFFFFFF)))
|
|
(when (>= j (expt 2 63))
|
|
(<- j (- j (expt 2 64))))
|
|
(return j))
|
|
|
|
#|
|
|
(%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) (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
|
|
(case x
|
|
(:select (tag nan32 nan64 +infinity32 +infinity64 -infinity32 -infinity64) (return 0))
|
|
(: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 (:def-const limit integer) (:global-call pin-extended-integer i limit negative-from-end) " returns " (:local i) " pinned to the set "
|
|
(:expr (range-set integer) (range-set-of-ranges integer 0 limit)) ", where " (:local limit) " is a nonnegative integer. If "
|
|
(:local negative-from-end) " is " (:tag true)
|
|
", then negative values of " (:local i) " from " (:expr integer (neg limit)) " through " (:expr integer -1) " are treated as 0 through "
|
|
(:expr integer (- limit 1)) " respectively.")
|
|
(define (pin-extended-integer (i extended-integer) (limit integer) (negative-from-end boolean)) integer
|
|
(case i
|
|
(:select (tag nan) (throw-error -range-error))
|
|
(:select (tag -infinity) (return 0))
|
|
(:select (tag +infinity) (return limit))
|
|
(:narrow integer
|
|
(var j integer i)
|
|
(when (> j limit)
|
|
(<- j limit))
|
|
(when (and negative-from-end (< j 0))
|
|
(<- j (+ j limit)))
|
|
(when (< j 0)
|
|
(<- j 0))
|
|
(assert (cascade integer 0 <= j <= limit))
|
|
(return j))))
|
|
|
|
|
|
(%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
|
|
(case x
|
|
(:select (tag nan32 nan64 +infinity32 +infinity64 -infinity32 -infinity64) (return none))
|
|
(:select (tag +zero32 +zero64 -zero32 -zero64) (return 0))
|
|
(:narrow (union long u-long) (return (& value x)))
|
|
(:narrow (union nonzero-finite-float32 nonzero-finite-float64)
|
|
(const r rational (& value x))
|
|
(rwhen (not-in r integer :narrow-false)
|
|
(return none))
|
|
(return r))))
|
|
|
|
(%text :comment (:global-call integer-to-long i) " converts " (:local i) " to the first of the types " (:type long) ", " (:type u-long) ", or " (:type float64)
|
|
" that can contain the value " (:local i) ". If necessary, the " (:type float64) " result may be rounded or converted to an infinity using the IEEE 754 "
|
|
:left-double-quote "round to nearest" :right-double-quote " mode.")
|
|
(define (integer-to-long (i integer)) general-number
|
|
(cond
|
|
((cascade integer (neg (expt 2 63)) <= i <= (- (expt 2 63) 1))
|
|
(return (new long i)))
|
|
((cascade integer (expt 2 63) <= i <= (- (expt 2 64) 1))
|
|
(return (new u-long i)))
|
|
(nil
|
|
(return (real-to-float64 i)))))
|
|
|
|
(%text :comment (:global-call integer-to-u-long i) " converts " (:local i) " to the first of the types " (:type u-long) ", " (:type long) ", or " (:type float64)
|
|
" that can contain the value " (:local i) ". If necessary, the " (:type float64) " result may be rounded or converted to an infinity using the IEEE 754 "
|
|
:left-double-quote "round to nearest" :right-double-quote " mode.")
|
|
(define (integer-to-u-long (i integer)) general-number
|
|
(cond
|
|
((cascade integer 0 <= i <= (- (expt 2 64) 1))
|
|
(return (new u-long i)))
|
|
((cascade integer (neg (expt 2 63)) <= i <= -1)
|
|
(return (new long i)))
|
|
(nil
|
|
(return (real-to-float64 i)))))
|
|
|
|
(%text :comment (:global-call rational-to-long q) " converts " (:local q) " to one of the types " (:type long) ", " (:type u-long) ", or " (:type float64)
|
|
", whichever one can come the closest to representing the true value of " (:local q) ". If several of these types can come equally close to the value of "
|
|
(:local q) ", then one of them is chosen according to the algorithm below.")
|
|
(define (rational-to-long (q rational)) general-number
|
|
(cond
|
|
((in q integer :narrow-true) (return (integer-to-long q)))
|
|
((<= (rat-abs q) (expt 2 53) rational) (return (real-to-float64 q)))
|
|
((or (< q (rat- (neg (expt 2 63)) (rat/ 1 2)) rational) (>= q (rat- (expt 2 64) (rat/ 1 2)) rational)) (return (real-to-float64 q)))
|
|
(nil
|
|
(/* (:def-const i integer) "Let " (:local i) " be the integer closest to " (:local q)
|
|
". If " (:local q) " is halfway between two integers, pick " (:local i) " so that it is even.")
|
|
(var i integer (floor q))
|
|
(var frac rational (rat- q i))
|
|
(when (or (> frac (rat/ 1 2) rational) (and (= frac (rat/ 1 2) rational) (= (bitwise-and i 1) 1)))
|
|
(<- i (+ i 1)))
|
|
(*/)
|
|
(assert (cascade integer (neg (expt 2 63)) <= i <= (- (expt 2 64) 1)))
|
|
(if (< i (expt 2 63))
|
|
(return (new long i))
|
|
(return (new u-long i))))))
|
|
|
|
(%text :comment (:global-call rational-to-u-long q) " converts " (:local q) " to one of the types " (:type u-long) ", " (:type long) ", or " (:type float64)
|
|
", whichever one can come the closest to representing the true value of " (:local q) ". If several of these types can come equally close to the value of "
|
|
(:local q) ", then one of them is chosen according to the algorithm below.")
|
|
(define (rational-to-u-long (q rational)) general-number
|
|
(cond
|
|
((in q integer :narrow-true) (return (integer-to-u-long q)))
|
|
((<= (rat-abs q) (expt 2 53) rational) (return (real-to-float64 q)))
|
|
((or (< q (rat- (neg (expt 2 63)) (rat/ 1 2)) rational) (>= q (rat- (expt 2 64) (rat/ 1 2)) rational)) (return (real-to-float64 q)))
|
|
(nil
|
|
(/* (:def-const i integer) "Let " (:local i) " be the integer closest to " (:local q)
|
|
". If " (:local q) " is halfway between two integers, pick " (:local i) " so that it is even.")
|
|
(var i integer (floor q))
|
|
(var frac rational (rat- q i))
|
|
(when (or (> frac (rat/ 1 2) rational) (and (= frac (rat/ 1 2) rational) (= (bitwise-and i 1) 1)))
|
|
(<- i (+ i 1)))
|
|
(*/)
|
|
(assert (cascade integer (neg (expt 2 63)) <= i <= (- (expt 2 64) 1)))
|
|
(if (>= i 0)
|
|
(return (new u-long i))
|
|
(return (new long i))))))
|
|
|
|
|
|
(define (extended-rational-to-float32 (q extended-rational)) float32
|
|
(case q
|
|
(: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 (extended-rational-to-float64 (q extended-rational)) float64
|
|
(case q
|
|
(:narrow rational (return (real-to-float64 q)))
|
|
(:select (tag +zero) (return +zero64))
|
|
(:select (tag -zero) (return -zero64))
|
|
(:select (tag +infinity) (return +infinity64))
|
|
(:select (tag -infinity) (return -infinity64))
|
|
(:select (tag nan) (return nan64))))
|
|
|
|
|
|
(%text :comment (:global-call to-rational x) " returns the exact " (:type rational) " value of " (:local x) ".")
|
|
(define (to-rational (x finite-general-number)) rational
|
|
(case x
|
|
(: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
|
|
(case x
|
|
(:narrow (union long u-long) (return (real-to-float64 (& value x))))
|
|
(:narrow float32 (return (float32-to-float64 x)))
|
|
(:narrow float64 (return x))))
|
|
|
|
|
|
(%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)
|
|
", even if they have different types. Positive infinities compare equal to each other and greater than any other non-NaN values. Negative infinities compare "
|
|
"equal to each other and less than any other non-NaN values. Positive and negative zeroes compare equal to each other.")
|
|
(define (general-number-compare (x general-number) (y general-number)) order
|
|
(cond
|
|
((or (in x (tag nan32 nan64) :narrow-false) (in y (tag nan32 nan64) :narrow-false))
|
|
(return unordered))
|
|
((and (in x (tag +infinity32 +infinity64)) (in y (tag +infinity32 +infinity64)))
|
|
(return equal))
|
|
((and (in x (tag -infinity32 -infinity64)) (in y (tag -infinity32 -infinity64)))
|
|
(return equal))
|
|
((or (in x (tag +infinity32 +infinity64) :narrow-false) (in y (tag -infinity32 -infinity64) :narrow-false))
|
|
(return greater))
|
|
((or (in x (tag -infinity32 -infinity64) :narrow-false) (in y (tag +infinity32 +infinity64) :narrow-false))
|
|
(return less))
|
|
(nil
|
|
(const xr rational (to-rational x))
|
|
(const yr rational (to-rational y))
|
|
(cond
|
|
((< xr yr rational) (return less))
|
|
((> xr yr rational) (return greater))
|
|
(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 (char21-to-u-t-f16 (ch char21)) string
|
|
(return (integer-to-u-t-f16 (char21-to-integer ch))))
|
|
|
|
|
|
(define (surrogate-pair-to-supplementary-char (h char16) (l char16)) supplementary-char
|
|
(const code-point (integer-range (hex #x10000) (hex #x10FFFF))
|
|
(+ (+ (hex #x10000) (* (- (char16-to-integer h) (hex #xD800)) (hex #x400))) (- (char16-to-integer l) (hex #xDC00))))
|
|
(return (integer-to-supplementary-char code-point)))
|
|
|
|
|
|
(define (string-to-u-t-f32 (s string)) (vector char21)
|
|
(var i integer 0)
|
|
(var result (vector char21) (vector-of char21))
|
|
(while (/= i (length s))
|
|
(var ch char21)
|
|
(cond
|
|
((and (set-in (nth s i) (range-set-of-ranges char16 #?D800 #?DBFF)) (/= (+ i 1) (length s)) (set-in (nth s (+ i 1)) (range-set-of-ranges char16 #?DC00 #?DFFF)))
|
|
(<- ch (surrogate-pair-to-supplementary-char (nth s i) (nth s (+ i 1))))
|
|
(<- i (+ i 2)))
|
|
(nil
|
|
(<- ch (nth s i))
|
|
(<- i (+ i 1))))
|
|
(<- result (append result (vector ch))))
|
|
(return result))
|
|
|
|
|
|
(define (char-to-lower-full (ch char21)) 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 (char21-to-u-t-f16 ch)) ".")
|
|
(cond
|
|
((in ch supplementary-char :narrow-both)
|
|
(return (char21-to-u-t-f16 ch))) ;Don't worry for now about converting the case of these
|
|
(nil (return (vector (lisp-call char-downcase (ch) char16))))))
|
|
|
|
|
|
(define (char-to-lower-localized (ch char21)) 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 (char21-to-u-t-f16 ch)) ".")
|
|
(cond
|
|
((in ch supplementary-char :narrow-both)
|
|
(return (char21-to-u-t-f16 ch))) ;Don't worry for now about converting the case of these
|
|
(nil (return (vector (lisp-call char-downcase (ch) char16))))))
|
|
|
|
|
|
(define (char-to-upper-full (ch char21)) 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 (char21-to-u-t-f16 ch)) ".")
|
|
(cond
|
|
((in ch supplementary-char :narrow-both)
|
|
(return (char21-to-u-t-f16 ch))) ;Don't worry for now about converting the case of these
|
|
(nil (return (vector (lisp-call char-upcase (ch) char16))))))
|
|
|
|
|
|
(define (char-to-upper-localized (ch char21)) 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 (char21-to-u-t-f16 ch)) ".")
|
|
(cond
|
|
((in ch supplementary-char :narrow-both)
|
|
(return (char21-to-u-t-f16 ch))) ;Don't worry for now about converting the case of these
|
|
(nil (return (vector (lisp-call char-downcase (ch) char16))))))
|
|
|
|
|
|
(%heading (2 :semantics) "Object Utilities")
|
|
(%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)
|
|
" on an object.")
|
|
(define (object-type (o object)) class
|
|
(case o
|
|
(:select undefined (return -void))
|
|
(:select null (return -null))
|
|
(:select boolean (return -boolean))
|
|
(:select long (return \#long))
|
|
(:select u-long (return ulong))
|
|
(:select float32 (return float))
|
|
(:select float64 (return -number))
|
|
(:select char16 (return char))
|
|
(:select string (return -string))
|
|
(:select namespace (return -namespace))
|
|
(:select compound-attribute (return -attribute))
|
|
(:select class (return -class))
|
|
(:narrow simple-instance (return (& type o)))
|
|
(:select method-closure (return -function))
|
|
(:select date (return -date))
|
|
(:select reg-exp (return -reg-exp))
|
|
(:select package (return -package))))
|
|
|
|
|
|
(%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)))
|
|
|
|
|
|
(%text :comment (:global-call ordinary-is o c) " is the implementation of " (:global is) " for a native class unless specified otherwise in the class" :apostrophe
|
|
"s definition. Host classes may either also use " (:global ordinary-is) " or define a different procedure to perform this test.")
|
|
(define (ordinary-is (o object) (c class)) boolean
|
|
(return (is-ancestor c (object-type o))))
|
|
|
|
|
|
(%text :comment "Return an ordered list of class " (:local c) :apostrophe "s ancestors, including " (:local c) " itself.")
|
|
(define (ancestors (c class)) (vector class)
|
|
(const s class-opt (& super c))
|
|
(if (in s (tag none) :narrow-false)
|
|
(return (vector c))
|
|
(return (append (ancestors s) (vector c)))))
|
|
|
|
(%text :comment "Return " (:tag true) " if " (:local c) " is " (:local d) " or an ancestor of " (:local d) ".")
|
|
(define (is-ancestor (c class) (d class)) boolean
|
|
(cond
|
|
((= c d class) (return true))
|
|
(nil (const s class-opt (& super d))
|
|
(rwhen (in s (tag none) :narrow-false)
|
|
(return false))
|
|
(return (is-ancestor c s)))))
|
|
|
|
#|
|
|
(%text :comment "Return " (:tag true) " if " (:local c) " is an ancestor of " (:local d) " other than " (:local d) " itself.")
|
|
(define (is-proper-ancestor (c class) (d class)) boolean
|
|
(return (and (is-ancestor c d) (/= c d class))))
|
|
|#
|
|
|
|
|
|
(%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))
|
|
(:narrow (union long u-long) (return (/= (& value o) 0)))
|
|
(:narrow float32 (return (not-in o (tag +zero32 -zero32 nan32))))
|
|
(:narrow float64 (return (not-in o (tag +zero64 -zero64 nan64))))
|
|
(:narrow string (return (/= o "" string)))
|
|
(:select (union char16 namespace compound-attribute class simple-instance method-closure date reg-exp package) (return true))))
|
|
|
|
|
|
(%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 false 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 false 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 false 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 false 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 (object-to-general-number (o object) (phase phase)) general-number
|
|
(const a primitive-object (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 a))
|
|
(:narrow (union char16 string) (return (string-to-float64 (to-string a))))))
|
|
|
|
|
|
(%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
|
|
(const a primitive-object (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-extended-integer o phase) " returns " (:local o) " converted to an " (:type extended-integer) ". An error occurs if "
|
|
(:local o) " has a fractional part or is a NaN. 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-extended-integer (o object) (phase phase)) extended-integer
|
|
(const a primitive-object (object-to-primitive o hint-number phase))
|
|
(case a
|
|
(:select (union null (tag false)) (return 0))
|
|
(:select (tag true) (return 1))
|
|
(:select (tag undefined nan32 nan64) (return nan))
|
|
(:select (tag +infinity32 +infinity64) (return +infinity))
|
|
(:select (tag -infinity32 -infinity64) (return -infinity))
|
|
(:select (tag +zero32 +zero64 -zero32 -zero64) (return 0))
|
|
(:narrow (union long u-long) (return (& value a)))
|
|
(:narrow (union nonzero-finite-float32 nonzero-finite-float64)
|
|
(const r rational (& value a))
|
|
(rwhen (not-in r integer :narrow-false)
|
|
(throw-error -range-error "the value " (:local a) " is not an integer"))
|
|
(return r))
|
|
(:narrow (union char16 string)
|
|
(return (string-to-extended-integer (to-string a))))))
|
|
|
|
|
|
(%text :comment (:global-call object-to-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-integer (o object) (phase phase)) integer
|
|
(const i extended-integer (object-to-extended-integer o phase))
|
|
(case i
|
|
(:select (tag +infinity -infinity nan) (throw-error -range-error (:local i) " is not an integer"))
|
|
(:narrow integer (return i))))
|
|
|
|
|
|
(define (string-to-float32 (s string)) float32
|
|
(/* "Apply the lexer grammar with the start symbol " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " to the string " (:local s) ".")
|
|
(const q (union extended-rational (tag syntax-error))
|
|
(lisp-call string-to-extended-rational (s)
|
|
(union extended-rational (tag syntax-error))
|
|
"the result of lexing " (:operand 0) " using " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " as the start symbol"))
|
|
(*/)
|
|
(cond
|
|
((/*/ (in q (tag syntax-error) :narrow-false)
|
|
"the grammar cannot interpret the entire string as an expansion of " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html"))
|
|
(return nan32))
|
|
(nil
|
|
(// (:local q) ":" :nbsp (:type extended-rational) " " :assign-10 " the value of the action " (:action lex) " applied to the obtained expansion of the nonterminal "
|
|
(:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") ";")
|
|
(return (extended-rational-to-float32 q)))))
|
|
|
|
|
|
(define (string-to-float64 (s string)) float64
|
|
(/* "Apply the lexer grammar with the start symbol " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " to the string " (:local s) ".")
|
|
(const q (union extended-rational (tag syntax-error))
|
|
(lisp-call string-to-extended-rational (s)
|
|
(union extended-rational (tag syntax-error))
|
|
"the result of lexing " (:operand 0) " using " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " as the start symbol"))
|
|
(*/)
|
|
(cond
|
|
((/*/ (in q (tag syntax-error) :narrow-false)
|
|
"the grammar cannot interpret the entire string as an expansion of " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html"))
|
|
(return nan64))
|
|
(nil
|
|
(// (:local q) ":" :nbsp (:type extended-rational) " " :assign-10 " the value of the action " (:action lex) " applied to the obtained expansion of the nonterminal "
|
|
(:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") ";")
|
|
(return (extended-rational-to-float64 q)))))
|
|
|
|
|
|
(define (string-to-extended-integer (s string)) extended-integer
|
|
(/* "Apply the lexer grammar with the start symbol " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " to the string " (:local s) ".")
|
|
(const q (union extended-rational (tag syntax-error))
|
|
(lisp-call string-to-extended-rational (s)
|
|
(union extended-rational (tag syntax-error))
|
|
"the result of lexing " (:operand 0) " using " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") " as the start symbol"))
|
|
(*/)
|
|
(cond
|
|
((/*/ (in q (tag syntax-error) :narrow-false)
|
|
"the grammar cannot interpret the entire string as an expansion of " (:grammar-symbol :string-numeric-literal nil "lexer-semantics.html"))
|
|
(throw-error -type-error "the string " (:local s) " does not contain a number"))
|
|
(nil
|
|
(// (:local q) ":" :nbsp (:type extended-rational) " " :assign-10 " the value of the action " (:action lex) " applied to the obtained expansion of the nonterminal "
|
|
(:grammar-symbol :string-numeric-literal nil "lexer-semantics.html") ";")
|
|
(case q
|
|
(:select (tag +zero -zero) (return 0))
|
|
(:narrow (tag +infinity -infinity nan) (return q))
|
|
(:narrow rational
|
|
(if (in q integer :narrow-true)
|
|
(return q)
|
|
(throw-error -range-error "the value should be an integer")))))))
|
|
|
|
|
|
(%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 (object-to-string (o object) (phase phase)) string
|
|
(const a primitive-object (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 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))))
|
|
|
|
|
|
(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 "
|
|
(:local i) " is negative, the string is preceded by a minus sign.")
|
|
(define (integer-to-string (i integer)) string
|
|
(rwhen (< i 0)
|
|
(return (cons #\- (integer-to-string (neg i)))))
|
|
(const q integer (floor (rat/ i 10)))
|
|
(const r integer (- i (* q 10)))
|
|
(const c char16 (integer-to-char16 (+ r (char16-to-integer #\0))))
|
|
(if (= q 0)
|
|
(return (vector c))
|
|
(return (append (integer-to-string q) (vector c)))))
|
|
|
|
|
|
(%text :comment (:global-call integer-to-string-with-sign i) " is the same as " (:global-call integer-to-string i)
|
|
" except that the resulting string always begins with a plus or minus sign.")
|
|
(define (integer-to-string-with-sign (i integer)) string
|
|
(if (>= i 0)
|
|
(return (cons #\+ (integer-to-string i)))
|
|
(return (cons #\- (integer-to-string (neg i))))))
|
|
|
|
|
|
(define (exponential-notation-string (digits string) (e integer)) string
|
|
(var mantissa string)
|
|
(if (= (length digits) 1)
|
|
(<- mantissa digits)
|
|
(<- mantissa (append (vector (nth digits 0)) "." (subseq digits 1))))
|
|
(return (append mantissa "e" (integer-to-string-with-sign e))))
|
|
|
|
|
|
(%text :comment (:global-call float32-to-string x) " converts a " (:type float32) " " (:local x) " to a string using fixed-point notation if "
|
|
"the absolute value of " (:local x) " is between " (:expr rational (expt 10 -6)) " inclusive and " (:expr rational (expt 10 21)) " exclusive, and "
|
|
"exponential notation otherwise. The result has the fewest significant digits possible while still ensuring that converting the string back into a "
|
|
(:type float32) " value would result in the same value " (:local x) " (except that " (:tag -zero32) " would become " (:tag +zero32) ").")
|
|
(define (float32-to-string (x float32)) string
|
|
(case x
|
|
(:select (tag nan32) (return "NaN"))
|
|
(:select (tag +zero32 -zero32) (return "0"))
|
|
(:select (tag +infinity32) (return "Infinity"))
|
|
(:select (tag -infinity32) (return "-Infinity"))
|
|
(:narrow nonzero-finite-float32
|
|
(const r rational (& value x))
|
|
(cond
|
|
((< r 0 rational) (return (append "-" (float32-to-string (float32-negate x)))))
|
|
(nil
|
|
(/* (:def-const e integer) (:def-const k integer) (:def-const s integer)
|
|
"Let " (:local e) ", " (:local k) ", and " (:local s) " be integers such that "
|
|
(:expr boolean (>= k 1)) ", " (:expr boolean (cascade rational (expt 10 (- k 1)) <= s <= (expt 10 k))) ", "
|
|
(:expr boolean (= (real-to-float32 (rat* s (expt 10 (- (+ e 1) k)))) x float32)) ", and " (:local k) " is as small as possible.")
|
|
(multiple-value-bind ((digits string) (e integer)) decompose-positive-float32 (x))
|
|
(const k integer (length digits))
|
|
(*/)
|
|
(note (:local k) " is the number of digits in the decimal representation of " (:local s) ", " (:local s)
|
|
" is not divisible by 10, and the least significant digit of " (:local s)
|
|
" is not necessarily uniquely determined by the above criteria.")
|
|
(// (:def-const s integer) "When there are multiple possibilities for " (:local s) " according to the rules above, "
|
|
"implementations are encouraged but not required to select the one according to the following rule: "
|
|
"Select the value of " (:local s) " for which " (:expr rational (rat* s (expt 10 (- (+ e 1) k)))) " is closest in value to " (:local r)
|
|
"; if there are two such possible values of " (:local s) ", choose the one that is even.")
|
|
(// (:def-const s integer) (:local digits) ":" :nbsp (:type string) :nbsp :assign-10 :nbsp (:expr string (integer-to-string s)))
|
|
(cond
|
|
((cascade integer (- k 1) <= e <= 20)
|
|
(return (append digits (repeat char16 #\0 (- (+ e 1) k)))))
|
|
((cascade integer 0 <= e <= 20)
|
|
(return (append (subseq digits 0 e) "." (subseq digits (+ e 1)))))
|
|
((cascade integer -6 <= e < 0)
|
|
(return (append "0." (repeat char16 #\0 (neg (+ e 1))) digits)))
|
|
(nil
|
|
(return (exponential-notation-string digits e)))))))))
|
|
;(defprimitive float32-to-string (lambda (x) (float32-to-string x)))
|
|
|
|
|
|
(%text :comment (:global-call float64-to-string x) " converts a " (:type float64) " " (:local x) " to a string using fixed-point notation if "
|
|
"the absolute value of " (:local x) " is between " (:expr rational (expt 10 -6)) " inclusive and " (:expr rational (expt 10 21)) " exclusive, and "
|
|
"exponential notation otherwise. The result has the fewest significant digits possible while still ensuring that converting the string back into a "
|
|
(:type float64) " value would result in the same value " (:local x) " (except that " (:tag -zero64) " would become " (:tag +zero64) ").")
|
|
(define (float64-to-string (x float64)) string
|
|
(case x
|
|
(:select (tag nan64) (return "NaN"))
|
|
(:select (tag +zero64 -zero64) (return "0"))
|
|
(:select (tag +infinity64) (return "Infinity"))
|
|
(:select (tag -infinity64) (return "-Infinity"))
|
|
(:narrow nonzero-finite-float64
|
|
(const r rational (& value x))
|
|
(cond
|
|
((< r 0 rational) (return (append "-" (float64-to-string (float64-negate x)))))
|
|
(nil
|
|
(/* (:def-const e integer) (:def-const k integer) (:def-const s integer)
|
|
"Let " (:local e) ", " (:local k) ", and " (:local s) " be integers such that "
|
|
(:expr boolean (>= k 1)) ", " (:expr boolean (cascade rational (expt 10 (- k 1)) <= s <= (expt 10 k))) ", "
|
|
(:expr boolean (= (real-to-float64 (rat* s (expt 10 (- (+ e 1) k)))) x float64)) ", and " (:local k) " is as small as possible.")
|
|
(multiple-value-bind ((digits string) (e integer)) decompose-positive-float64 (x))
|
|
(const k integer (length digits))
|
|
(*/)
|
|
(note (:local k) " is the number of digits in the decimal representation of " (:local s) ", " (:local s)
|
|
" is not divisible by 10, and the least significant digit of " (:local s)
|
|
" is not necessarily uniquely determined by the above criteria.")
|
|
(// (:def-const s integer) "When there are multiple possibilities for " (:local s) " according to the rules above, "
|
|
"implementations are encouraged but not required to select the one according to the following rule: "
|
|
"Select the value of " (:local s) " for which " (:expr rational (rat* s (expt 10 (- (+ e 1) k)))) " is closest in value to " (:local r)
|
|
"; if there are two such possible values of " (:local s) ", choose the one that is even.")
|
|
(// (:def-const s integer) (:local digits) ":" :nbsp (:type string) :nbsp :assign-10 :nbsp (:expr string (integer-to-string s)))
|
|
(cond
|
|
((cascade integer (- k 1) <= e <= 20)
|
|
(return (append digits (repeat char16 #\0 (- (+ e 1) k)))))
|
|
((cascade integer 0 <= e <= 20)
|
|
(return (append (subseq digits 0 e) "." (subseq digits (+ e 1)))))
|
|
((cascade integer -6 <= e < 0)
|
|
(return (append "0." (repeat char16 #\0 (neg (+ e 1))) digits)))
|
|
(nil
|
|
(return (exponential-notation-string digits e)))))))))
|
|
;(defprimitive float64-to-string (lambda (x) (float64-to-string x)))
|
|
|
|
|
|
(%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 (object-to-qualified-name (o object) (phase phase)) qualified-name
|
|
(return (new qualified-name public (object-to-string o phase))))
|
|
|
|
|
|
(%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) "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
|
|
(note "If " (:local o) " is not an attribute, try to call it with no arguments.")
|
|
(const a object (call null o (vector-of object) phase))
|
|
(if (in a attribute :narrow-true)
|
|
(return a)
|
|
(throw-error -type-error)))))
|
|
|
|
|
|
(%heading (3 :semantics) "Implicit Coercions")
|
|
(%text :comment (:global-call coerce o c) " attempts to implicitly coerce " (:local o) " to class " (:local c) ". If the coercion succeeds, "
|
|
(:global coerce) " returns the coerced value. If not, " (:global coerce) " 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 coerce) " always is a member of class " (:local c) ".")
|
|
(define (coerce (o object) (c class)) object
|
|
(const result object-opt ((& coerce c) o c))
|
|
(if (not-in result (tag none) :narrow-true)
|
|
(return result)
|
|
(throw-error -type-error "coercion failed")))
|
|
|
|
|
|
(%text :comment (:global-call coerce-or-null o c) " attempts to implicitly coerce " (:local o) " to class " (:local c) ". If the coercion succeeds, "
|
|
(:global coerce-or-null) " returns the coerced value. If not, then " (:global coerce-or-null) " returns " (:tag null) " if "
|
|
(:tag null) " is a member of type " (:local c) "; otherwise, " (:global coerce-or-null) " 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 coerce-or-null) " always is a member of class " (:local c) ".")
|
|
(define (coerce-or-null (o object) (c class)) object
|
|
(const result object-opt ((& coerce c) o c))
|
|
(cond
|
|
((not-in result (tag none) :narrow-true)
|
|
(return result))
|
|
((= ((& coerce c) null c) null object-opt)
|
|
(return null))
|
|
(nil (throw-error -type-error "coercion failed"))))
|
|
|
|
|
|
(%text :comment (:global-call coerce-non-null o c) " attempts to implicitly coerce " (:local o) " to class " (:local c)
|
|
". If the coercion succeeds and the result is not " (:tag null) ", then "
|
|
(:global coerce-non-null) " returns the coerced value. If not, " (:global coerce-non-null) " throws a " (:global -type-error) ".")
|
|
(define (coerce-non-null (o object) (c class)) object
|
|
(const result object-opt ((& coerce c) o c))
|
|
(if (not-in result (tag none null) :narrow-true)
|
|
(return result)
|
|
(throw-error -type-error "coercion failed")))
|
|
|
|
|
|
(%text :comment (:global-call ordinary-coerce o c) " is the implementation of coercion for a native class unless specified otherwise in the class" :apostrophe
|
|
"s definition. Host classes may define a different procedure to perform this coercion.")
|
|
(define (ordinary-coerce (o object) (c class)) object-opt
|
|
(if (or (in o (tag null)) (is o c))
|
|
(return o)
|
|
(return none)))
|
|
|
|
|
|
(%heading (3 :semantics) "Attributes")
|
|
(%text :comment (:global-call combine-attributes a b) " returns the attribute that results from concatenating the attributes "
|
|
(:local a) " and " (:local b) ".")
|
|
(define (combine-attributes (a attribute-opt-not-false) (b attribute)) attribute
|
|
(cond
|
|
((in b false-type :narrow-false) (return false))
|
|
((in a (tag none true) :narrow-false) (return b))
|
|
((in b true-type :narrow-false) (return a))
|
|
((in a namespace :narrow-both)
|
|
(cond
|
|
((= a b attribute) (return a))
|
|
((in b namespace :narrow-both)
|
|
(return (new compound-attribute (list-set a b) false false false none none false false)))
|
|
(nil
|
|
(return (set-field b namespaces (set+ (& namespaces b) (list-set a)))))))
|
|
((in b namespace :narrow-both)
|
|
(return (set-field a namespaces (set+ (& namespaces a) (list-set b)))))
|
|
(nil
|
|
(note "At this point both " (:local a) " and " (:local b) " are compound attributes.")
|
|
(if (or (and (not-in (& category a) (tag none)) (not-in (& category b) (tag none)) (/= (& category a) (& category b) property-category))
|
|
(and (not-in (& override-mod a) (tag none)) (not-in (& override-mod b) (tag none)) (/= (& override-mod a) (& override-mod b) override-modifier)))
|
|
(throw-error -attribute-error "attributes " (:local a) " and " (:local b) " have conflicting contents")
|
|
(return (new compound-attribute
|
|
(set+ (& namespaces a) (& namespaces b))
|
|
(or (& explicit a) (& explicit b))
|
|
(or (& enumerable a) (& enumerable b))
|
|
(or (& dynamic a) (& dynamic b))
|
|
(if (not-in (& category a) (tag none)) (& category a) (& category b))
|
|
(if (not-in (& override-mod a) (tag none)) (& override-mod a) (& override-mod b))
|
|
(or (& prototype a) (& prototype b))
|
|
(or (& unused a) (& unused b))))))))
|
|
|
|
|
|
(%text :comment (:global-call to-compound-attribute a) " returns " (:local a) " converted to a " (:type compound-attribute)
|
|
" even if it was a simple namespace, " (:tag true) ", or " (:tag none) ".")
|
|
(define (to-compound-attribute (a attribute-opt-not-false)) compound-attribute
|
|
(case a
|
|
(:select (tag none true) (return (new compound-attribute (list-set-of namespace) false false false none none false false)))
|
|
(:narrow namespace (return (new compound-attribute (list-set a) false false false none none false false)))
|
|
(:narrow compound-attribute (return a))))
|
|
|
|
|
|
(%heading (2 :semantics) "Access Utilities")
|
|
(%text :comment (:global-call accesses-overlap accesses1 accesses2) " returns " (:tag true) " if the two " (:type access-set) "s have a nonempty intersection.")
|
|
(define (accesses-overlap (accesses1 access-set) (accesses2 access-set)) boolean
|
|
(return (or (= accesses1 accesses2 access-set)
|
|
(in accesses1 (tag read-write))
|
|
(in accesses2 (tag read-write)))))
|
|
|
|
|
|
(define (archetype (o object)) object-opt
|
|
(case o
|
|
(:select (union undefined null) (return none))
|
|
(:select boolean (return (&opt prototype -boolean)))
|
|
(:select long (return (&opt prototype \#long)))
|
|
(:select u-long (return (&opt prototype ulong)))
|
|
(:select float32 (return (&opt prototype float)))
|
|
(:select float64 (return (&opt prototype -number)))
|
|
(:select char16 (return (&opt prototype char)))
|
|
(: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 class (return (&opt prototype -class)))
|
|
(:narrow (union simple-instance reg-exp date package) (return (&opt archetype o)))))
|
|
|
|
|
|
(%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)))
|
|
(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 (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)))
|
|
|
|
|
|
(%text :comment (:global-call setup-variable v) " runs " (:action setup) " and initialises the type of the variable " (:local v)
|
|
", making sure that " (:action setup) " is done at most once and does not reenter itself.")
|
|
(define (setup-variable (v variable)) void
|
|
(const setup (union (-> () class-opt) (tag none busy)) (& setup v))
|
|
(case setup
|
|
(:narrow (-> () class-opt)
|
|
(&= setup v busy)
|
|
(var type class-opt (setup))
|
|
(when (in type (tag none))
|
|
(<- type -object))
|
|
(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-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 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-initializer boolean)) object
|
|
(const coerced-value object (coerce new-value (&opt type v)))
|
|
(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))
|
|
|
|
|
|
(%heading (2 :semantics) "Environmental Utilities")
|
|
|
|
(%text :comment "If " (:local env) " is from within a class" :apostrophe "s body, "
|
|
(:global-call get-enclosing-class env) " returns the innermost such class; otherwise, it returns " (:tag none) ".")
|
|
(define (get-enclosing-class (env environment)) class-opt
|
|
(reserve c)
|
|
(rwhen (some env c (in c class :narrow-true) :define-true)
|
|
(// "Let " (:local c) " be the first element of " (:local env) " that is a " (:type class) ".")
|
|
(return c))
|
|
(return none))
|
|
|
|
|
|
(%text :comment "If " (:local env) " is from within a function" :apostrophe "s body, "
|
|
(:global-call get-enclosing-parameter-frame env) " returns the " (:type parameter-frame) " for the innermost such function; otherwise, it returns " (:tag none) ".")
|
|
(define (get-enclosing-parameter-frame (env environment)) parameter-frame-opt
|
|
(for-each env frame
|
|
(case frame
|
|
(:select (union local-frame with-frame))
|
|
(:narrow parameter-frame (return frame))
|
|
(:select (union package class) (return none))))
|
|
(return none))
|
|
|
|
|
|
(%text :comment (:global-call get-regional-environment env) " returns all frames in " (:local env) " up to and including the first regional frame. "
|
|
"A regional frame is either any frame other than a with frame or local block frame, a local block frame directly enclosed in a class, or "
|
|
"a local block frame directly enclosed in a with frame directly enclosed in a class.")
|
|
(define (get-regional-environment (env environment)) (vector frame)
|
|
(var i integer 0)
|
|
(while (in (nth env i) (union local-frame with-frame))
|
|
(<- i (+ i 1)))
|
|
(when (in (nth env i) class)
|
|
(while (and (/= i 0) (not-in (nth env i) local-frame))
|
|
(<- i (- i 1))))
|
|
(return (subseq env 0 i)))
|
|
|
|
|
|
(%text :comment (:global-call get-regional-frame env) " returns the most specific regional frame in " (:local env) ".")
|
|
(define (get-regional-frame (env environment)) frame
|
|
(const regional-env (vector frame) (get-regional-environment env))
|
|
(return (nth regional-env (- (length regional-env) 1))))
|
|
|
|
|
|
(%text :comment (:global-call get-package-frame env) " returns the innermost package frame in " (:local env) ".")
|
|
(define (get-package-frame (env environment)) package
|
|
(var i integer 0)
|
|
(while (not-in (nth env i) package)
|
|
(<- i (+ i 1)))
|
|
(note "Every environment ends with a " (:type package) " frame, so one will always be found.")
|
|
(return (assert-in (nth env i) package)))
|
|
|
|
|
|
|
|
(%heading (2 :semantics) "Property Lookup")
|
|
|
|
(%text :comment (:global-call find-local-singleton-property o multiname access) " looks in " (:local o) " for a local singleton property with one of the names in "
|
|
(:local multiname) " and access that includes " (:local access) ". If there is no such property, " (:global find-local-singleton-property)
|
|
" returns " (:tag none) ". If there is exactly one such property, " (:global find-local-singleton-property)
|
|
" returns it. If there is more than one such property, " (:global find-local-singleton-property) " throws an error.")
|
|
(define (find-local-singleton-property (o (union non-with-frame simple-instance reg-exp date)) (multiname multiname) (access access))
|
|
singleton-property-opt
|
|
(const matching-local-bindings (list-set local-binding)
|
|
(map (& local-bindings o) b b (and (set-in (& qname b) multiname) (accesses-overlap (& accesses b) access))))
|
|
(note "If the same property was found via several different bindings " (:local b)
|
|
", then it will appear only once in the set " (:local matching-properties) ".")
|
|
(const matching-properties (list-set singleton-property) (map matching-local-bindings b (& content b)))
|
|
(cond
|
|
((empty matching-properties)
|
|
(return none))
|
|
((= (length matching-properties) 1)
|
|
(return (unique-elt-of matching-properties)))
|
|
(nil
|
|
(throw-error -reference-error "this access is ambiguous because the bindings it found belong to several different local properties"))))
|
|
|
|
|
|
(%text :comment (:global-call instance-property-accesses m) " returns instance property" :apostrophe "s " (:type access-set) ".")
|
|
(define (instance-property-accesses (m instance-property)) access-set
|
|
(case m
|
|
(:select (union instance-variable instance-method) (return read-write))
|
|
(:select instance-getter (return read))
|
|
(:select instance-setter (return write))))
|
|
|
|
|
|
(%text :comment (:global-call find-local-instance-property c multiname accesses) " looks in class " (:local c) " for a local instance property with one of the names in "
|
|
(:local multiname) " and accesses that have a nonempty intersection with " (:local accesses) ". If there is no such property, " (:global find-local-instance-property)
|
|
" returns " (:tag none) ". If there is exactly one such property, " (:global find-local-instance-property)
|
|
" returns it. If there is more than one such property, " (:global find-local-instance-property) " throws an error.")
|
|
(define (find-local-instance-property (c class) (multiname multiname) (accesses access-set))
|
|
instance-property-opt
|
|
(const matches (list-set instance-property)
|
|
(map (& instance-properties c) m m (and (nonempty (set* (&opt multiname m) multiname)) (accesses-overlap (instance-property-accesses m) accesses))))
|
|
(cond
|
|
((empty matches)
|
|
(return none))
|
|
((= (length matches) 1)
|
|
(return (unique-elt-of matches)))
|
|
(nil
|
|
(throw-error -reference-error "this access is ambiguous because it found several different instance properties in the same class"))))
|
|
|
|
|
|
(%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 properties inherited from the archetype are not considered in the search. 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
|
|
(:select (union undefined null boolean long u-long float32 float64 char16 string namespace compound-attribute method-closure)
|
|
(<- m none))
|
|
(:narrow (union simple-instance reg-exp date package)
|
|
(<- m (find-local-singleton-property o multiname access)))
|
|
(:narrow class
|
|
(<- m (find-class-property o multiname access))))
|
|
(rwhen (not-in m (tag none))
|
|
(return m))
|
|
(rwhen flat
|
|
(return none))
|
|
(const a object-opt (archetype o))
|
|
(rwhen (in a (tag none) :narrow-false)
|
|
(return none))
|
|
(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)
|
|
" and its ancestors for an instance property with one of the names in "
|
|
(:local multiname) " and accesses that have a nonempty intersection with " (:local accesses) ". If there is no such property, " (:global find-base-instance-property)
|
|
" returns " (:tag none) ". If there is exactly one such property, " (:global find-base-instance-property)
|
|
" returns it. If there is more than one such property, " (:global find-base-instance-property)
|
|
" prefers the one defined in the least specific class; if two or more properties still remain, "
|
|
(:global find-base-instance-property) " throws an error.")
|
|
(define (find-base-instance-property (c class) (multiname multiname) (accesses access-set))
|
|
instance-property-opt
|
|
(note "Start from the root class (" (:character-literal "Object") ") and proceed through more specific classes that are ancestors of " (:local c) ".")
|
|
(for-each (ancestors c) s
|
|
(const m instance-property-opt (find-local-instance-property s multiname accesses))
|
|
(rwhen (not-in m (tag none))
|
|
(return m)))
|
|
(return none))
|
|
|
|
|
|
(%text :comment (:global-call get-derived-instance-property c m-base accesses) " returns the most derived instance property whose name includes that of " (:local m-base)
|
|
" and whose accesses that have a nonempty intersection with " (:local accesses) ". The caller of " (:global get-derived-instance-property)
|
|
" ensures that such an instance property always exists. "
|
|
"If " (:local accesses) " is " (:tag read-write) " then it is possible that this search could find both a getter and a setter defined in the same class; "
|
|
"in this case either the getter or the setter is returned at the implementation" :apostrophe "s discretion.")
|
|
(define (get-derived-instance-property (c class) (m-base instance-property) (accesses access-set)) instance-property
|
|
(reserve m)
|
|
(if (some (& instance-properties c) m (and (set<= (&opt multiname m-base) (&opt multiname m) multiname)
|
|
(accesses-overlap (instance-property-accesses m) accesses)) :define-true)
|
|
(return m)
|
|
(return (get-derived-instance-property (assert-not-in (& super c) (tag none)) m-base accesses))))
|
|
|
|
|
|
(%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)
|
|
" throws an error if there is no well-defined implicit " (:character-literal "this") " value or if an attempt is made to read it before it has been initialised.")
|
|
(define (read-implicit-this (env environment)) object
|
|
(const frame parameter-frame-opt (get-enclosing-parameter-frame env))
|
|
(rwhen (in frame (tag none) :narrow-false)
|
|
(throw-error -reference-error "can" :apostrophe "t access instance properties outside an instance method without supplying an instance object"))
|
|
(const this object-opt (& this frame))
|
|
(rwhen (in this (tag none) :narrow-false)
|
|
(throw-error -reference-error "can" :apostrophe "t access instance properties inside a non-instance method without supplying an instance object"))
|
|
(rwhen (not-in (& kind frame) (tag instance-function constructor-function))
|
|
(throw-error -reference-error "can" :apostrophe "t access instance properties inside a non-instance method without supplying an instance object"))
|
|
(rwhen (not (& superconstructor-called frame))
|
|
(throw-error -uninitialized-error "can" :apostrophe "t access instance properties from within a constructor before the superconstructor has been called"))
|
|
(return this))
|
|
|
|
|
|
(%text :comment (:global-call has-property o property flat phase) " returns " (:tag true) " if " (:local o) " has a readable or writable property named "
|
|
(:local property) ". If " (:local flat) " is " (:tag true) ", then properties inherited from the archetype are not considered.")
|
|
(define (has-property (o object) (property object) (flat boolean) (phase phase)) boolean
|
|
(const c class (object-type o))
|
|
(return ((& has-property c) o c property flat phase)))
|
|
|
|
|
|
(%text :comment (:global-call has-property o c property flat phase) " is the implementation of " (:global has-property)
|
|
" for a native class unless specified otherwise in the class" :apostrophe
|
|
"s definition. Host classes may either also use " (:global ordinary-has-property) " or define a different procedure to perform this test. "
|
|
(:local c) " is " (:local o) :apostrophe "s type.")
|
|
(define (ordinary-has-property (o object) (c class) (property object) (flat boolean) (phase phase)) boolean
|
|
(const qname qualified-name (object-to-qualified-name property phase))
|
|
(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 "
|
|
(:local r) " is a " (:type reference) ", " (:global read-reference) " reads " (:local r) " and returns the result. If "
|
|
(:local phase) " is " (:tag compile) ", only constant expressions can be evaluated in the process of reading " (:local r) ".")
|
|
(define (read-reference (r obj-or-ref) (phase phase)) object
|
|
(var result object-opt)
|
|
(case r
|
|
(: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) (& multiname r) none true phase)))
|
|
(:narrow bracket-reference
|
|
(<- result ((& bracket-read (& limit r)) (& base r) (& limit r) (& args r) true phase))))
|
|
(if (not-in result (tag none) :narrow-true)
|
|
(return result)
|
|
(throw-error -reference-error "property not found, and no default value is available")))
|
|
|
|
|
|
(%text :comment (:global-call dot-read o multiname phase) " reads and returns the value of the " (:local multiname) " property of " (:local o) ". "
|
|
(:global dot-read) " throws an error if the property does not exist and no default value was available for it.")
|
|
(define (dot-read (o object) (multiname multiname) (phase phase))
|
|
object
|
|
(const limit class (object-type o))
|
|
(const result object-opt ((& read limit) o limit multiname none true phase))
|
|
(rwhen (in result (tag none) :narrow-false)
|
|
(throw-error -reference-error "property not found, and no default value is available"))
|
|
(return result))
|
|
|
|
|
|
(%text :comment (:global-call read-length o phase) " reads and returns the value of the " (:character-literal "length") " property of " (:local o)
|
|
", ensuring that it is an integer between 0 and " (:global array-limit) " inclusive.")
|
|
(define (read-length (o object) (phase phase)) integer
|
|
(var value object (dot-read o (list-set (new qualified-name public "length")) phase))
|
|
(rwhen (not-in value general-number :narrow-false)
|
|
(throw-error -type-error "length not an integer"))
|
|
(const length integer-opt (check-integer value))
|
|
(cond
|
|
((in length (tag none) :narrow-false) (throw-error -range-error "length not an integer"))
|
|
((cascade integer 0 <= length <= array-limit) (return length))
|
|
(nil (throw-error -range-error "length out of range"))))
|
|
|
|
|
|
(%text :comment (:global-call index-read o i phase) " returns the value of " (:local o) (:character-literal "[") (:local i) (:character-literal "]")
|
|
" or " (:tag none) " if no such property was found; unlike " (:global dot-read) ", " (:global index-read)
|
|
" does not return a default value for missing properties. " (:local i) " should always be a valid array index.")
|
|
(define (index-read (o object) (i integer) (phase phase))
|
|
object-opt
|
|
(assert (cascade integer 0 <= i < array-limit))
|
|
(const limit class (object-type o))
|
|
(const x float64 (real-to-float64 i))
|
|
(const result object-opt ((& bracket-read limit) o limit (vector x) false phase))
|
|
(when (and (not-in result (tag none)) (not (has-property o x true phase)))
|
|
(// "At the implementation" :apostrophe "s discretion either do nothing, set " (:local result) " to " (:tag none) ", or "
|
|
(:keyword throw) " a " (:global -reference-error) "."))
|
|
(return result))
|
|
|
|
|
|
(%text :comment (:def-const o object) (:global-call ordinary-bracket-read o limit args undefined-if-missing phase) " evaluates the expression "
|
|
(:local o) (:character-literal "[") (:local args) (:character-literal "]") " when " (:local o) " is a native object. Host objects may either also use "
|
|
(:global ordinary-bracket-read) " or choose a different procedure " (:local -p) " to evaluate " (:local o) (:character-literal "[") (:local args) (:character-literal "]")
|
|
" by writing " (:local -p) " into " (:expr (-> (object class (vector object) boolean phase) object-opt) (& bracket-read (object-type o))) ".")
|
|
(%text :comment (:def-const o object) (:local limit) " is used to handle the expression "
|
|
(:character-literal "super(") (:local o) (:character-literal ")[") (:local args) (:character-literal "]")
|
|
", in which case " (:local limit) " is the superclass of the class inside which the " (:character-literal "super") " expression appears. "
|
|
"Otherwise, " (:local limit) " is set to " (:expr class (object-type o)) ".")
|
|
(define (ordinary-bracket-read (o object) (limit class) (args (vector object)) (undefined-if-missing boolean) (phase phase)) object-opt
|
|
(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 ((& read limit) o limit (list-set qname) none undefined-if-missing phase)))
|
|
|
|
|
|
(define (lexical-read (env environment) (multiname multiname) (phase phase)) object
|
|
(var i integer 0)
|
|
(while (< i (length env))
|
|
(const frame frame (nth env i))
|
|
(var result object-opt none)
|
|
(case frame
|
|
(:narrow (union package class)
|
|
(const limit class (object-type frame))
|
|
(<- result ((& read limit) frame limit multiname env false phase)))
|
|
(:narrow (union parameter-frame local-frame)
|
|
(const m singleton-property-opt (find-local-singleton-property frame multiname read))
|
|
(when (not-in m (tag none) :narrow-true)
|
|
(<- result (read-singleton-property m phase))))
|
|
(:narrow with-frame
|
|
(const value object-opt (& value frame))
|
|
(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"))
|
|
(:select (tag run)
|
|
(throw-error -uninitialized-error
|
|
"cannot read a " (:character-literal "with") " statement" :apostrophe "s frame before that statement" :apostrophe
|
|
"s expression has been evaluated"))))
|
|
(const limit class (object-type value))
|
|
(<- result ((& read limit) value limit multiname env false phase))))
|
|
(rwhen (not-in result (tag none) :narrow-true)
|
|
(return result))
|
|
(<- i (+ i 1)))
|
|
(throw-error -reference-error "no property found with the name " (:local multiname)))
|
|
|
|
|
|
(define (ordinary-read (o object) (limit class) (multiname multiname) (env environment-opt) (undefined-if-missing boolean) (phase phase))
|
|
object-opt
|
|
(const m-base instance-property-opt (find-base-instance-property limit multiname read))
|
|
(rwhen (not-in m-base (tag none) :narrow-true)
|
|
(return (read-instance-property o limit m-base phase)))
|
|
(rwhen (/= limit (object-type o) class)
|
|
(return none))
|
|
(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 undefined-if-missing
|
|
(in o (union simple-instance date reg-exp package) :narrow-true)
|
|
(not (& sealed o)))
|
|
(case phase
|
|
(:select (tag compile) (throw-error -constant-error "a constant expression cannot read dynamic properties"))
|
|
(:select (tag run) (return undefined)))
|
|
(return none)))
|
|
(:narrow singleton-property (return (read-singleton-property m phase)))
|
|
(:narrow instance-property
|
|
(rwhen (or (not-in o class :narrow-false) (in env (tag none) :narrow-false))
|
|
(throw-error -reference-error "cannot read an instance property without supplying an instance"))
|
|
(const this object (read-implicit-this env))
|
|
(return (read-instance-property this (object-type this) m phase)))))
|
|
|
|
|
|
(%text :comment (:global-call read-instance-property o qname phase) " is a simplified interface to "
|
|
(:global ordinary-read) " used to read instance slots that are known to exist.")
|
|
(define (read-instance-slot (o object) (qname qualified-name) (phase phase))
|
|
object
|
|
(const c class (object-type o))
|
|
(const m-base instance-property-opt (find-base-instance-property c (list-set qname) read))
|
|
(assert (not-in m-base (tag none) :narrow-true)
|
|
(:global read-instance-property) " is only called in cases where the instance property is known to exist, so " (:local m-base) " cannot be " (:tag none) " here.")
|
|
(return (read-instance-property o c m-base phase)))
|
|
|
|
|
|
(define (read-instance-property (this object) (c class) (m-base instance-property) (phase phase))
|
|
object
|
|
(const m instance-property (get-derived-instance-property c m-base read))
|
|
(case m
|
|
(:narrow instance-variable
|
|
(rwhen (and (in phase (tag compile)) (not (& immutable m)))
|
|
(throw-error -constant-error "a constant expression cannot read mutable variables"))
|
|
(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 uninitalised " (:character-literal "const") " variables from a constant expression"))
|
|
(:select (tag run) (throw-error -uninitialized-error "cannot read a " (:character-literal "const") " instance variable before it is initialised"))))
|
|
(return v))
|
|
(:narrow instance-method
|
|
(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
|
|
(bottom (:local m) " cannot be an " (:type instance-setter) " because these are only represented as write-only properties."))))
|
|
|
|
|
|
(define (read-singleton-property (m singleton-property) (phase phase)) object
|
|
(case m
|
|
(:select (tag forbidden)
|
|
(throw-error -reference-error "cannot access a property defined in a scope outside the current region if any block inside the current region shadows it"))
|
|
(:narrow dynamic-var
|
|
(rwhen (in phase (tag compile))
|
|
(throw-error -constant-error "a constant expression cannot read mutable variables"))
|
|
(var value (union object uninstantiated-function) (& value m))
|
|
(assert (not-in value uninstantiated-function :narrow-true)
|
|
(:local value) " can be an " (:type uninstantiated-function) " only during the " (:tag compile) " phase, which was ruled out above.")
|
|
(return value))
|
|
(:narrow variable
|
|
(rwhen (and (in phase (tag compile)) (not (& immutable m)))
|
|
(throw-error -constant-error "a constant expression cannot read mutable variables"))
|
|
(const value variable-value (& value m))
|
|
(case value
|
|
(:narrow object (return value))
|
|
(:select (tag none)
|
|
(rwhen (not (& immutable m))
|
|
(throw-error -uninitialized-error))
|
|
(note "Try to run a " (:character-literal "const") " variable" :apostrophe "s initialiser if there is one.")
|
|
(setup-variable m)
|
|
(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))))
|
|
(&= initializer m busy)
|
|
(var coerced-value object)
|
|
(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 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
|
|
(assert (in phase (tag compile)) "An uninstantiated function can only be found when " (:assertion) ".")
|
|
(throw-error -constant-error "an uninstantiated function is not a constant expression"))))
|
|
(:narrow getter
|
|
(const env environment-opt (& env m))
|
|
(rwhen (in env (tag none) :narrow-false)
|
|
(assert (in phase (tag compile)) "An uninstantiated getter can only be found when " (:assertion) ".")
|
|
(throw-error -constant-error "an uninstantiated getter is not a constant expression"))
|
|
(return ((& call m) env phase)))
|
|
(:narrow setter
|
|
(bottom (:local m) " cannot be a " (:type setter) " because these are only represented as write-only properties."))))
|
|
|
|
|
|
(%heading (2 :semantics) "Writing")
|
|
(%text :comment "If " (:local r) " is a reference, " (:global-call write-reference r new-value) " writes " (:local new-value)
|
|
" into " (:local r) ". An error occurs if " (:local r) " is not a reference. "
|
|
(:global write-reference) " is never called from a constant expression.")
|
|
(define (write-reference (r obj-or-ref) (new-value object) (phase (tag run))) void
|
|
(var result (tag none ok))
|
|
(case r
|
|
(:select object (throw-error -reference-error "a non-reference is not a valid target of an assignment"))
|
|
(:narrow lexical-reference
|
|
(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) (& multiname r) none new-value true phase)))
|
|
(:narrow bracket-reference
|
|
(<- result ((& bracket-write (& limit r)) (& base r) (& limit r) (& args r) new-value true phase))))
|
|
(rwhen (in result (tag none))
|
|
(throw-error -reference-error "property not found and could not be created")))
|
|
|
|
|
|
(%text :comment (:global-call dot-write o multiname new-value phase) " is a simplified interface to write " (:local new-value)
|
|
" into the " (:local multiname) " property of " (:local o) ".")
|
|
(define (dot-write (o object) (multiname multiname) (new-value object) (phase (tag run)))
|
|
void
|
|
(const limit class (object-type o))
|
|
(const result (tag none ok) ((& write limit) o limit multiname none new-value true phase))
|
|
(rwhen (in result (tag none))
|
|
(throw-error -reference-error "property not found and could not be created")))
|
|
|
|
|
|
(%text :comment (:global-call write-length o length phase) " ensures that " (:local length) " is between 0 and " (:global array-limit)
|
|
" inclusive and then writes it into the " (:character-literal "length") " property of " (:local o) ". Note that if " (:local o)
|
|
" is an " (:character-literal "Array") ", the act of writing its " (:character-literal "length") " property will invoke the "
|
|
(:global -array_set-length) " setter.")
|
|
(define (write-length (o object) (length integer) (phase (tag run))) void
|
|
(rwhen (or (< length 0) (> length array-limit))
|
|
(throw-error -range-error "length out of range"))
|
|
(dot-write o (list-set (new qualified-name public "length")) (real-to-float64 length) phase))
|
|
|
|
|
|
(define (index-write (o object) (i integer) (new-value object-opt) (phase (tag run)))
|
|
void
|
|
(rwhen (or (< i 0) (>= i array-limit))
|
|
(throw-error -range-error "index out of range"))
|
|
(const limit class (object-type o))
|
|
(cond
|
|
((in new-value (tag none) :narrow-false)
|
|
(const delete-result boolean-opt ((& bracket-delete limit) o limit (vector (real-to-float64 i)) phase))
|
|
(rwhen (in delete-result (tag false))
|
|
(throw-error -reference-error "cannot delete element")))
|
|
(nil
|
|
(const write-result (tag none ok) ((& bracket-write limit) o limit (vector (real-to-float64 i)) new-value true phase))
|
|
(rwhen (in write-result (tag none))
|
|
(throw-error -reference-error "element not found and could not be created")))))
|
|
|
|
|
|
(define (ordinary-bracket-write (o object) (limit class) (args (vector object)) (new-value object) (create-if-missing boolean) (phase (tag run)))
|
|
(tag none ok)
|
|
(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 ((& write limit) o limit (list-set qname) none new-value create-if-missing phase)))
|
|
|
|
|
|
(define (lexical-write (env environment) (multiname multiname) (new-value object) (create-if-missing boolean) (phase (tag run))) void
|
|
(var i integer 0)
|
|
(while (< i (length env))
|
|
(const frame frame (nth env i))
|
|
(var result (tag none ok) none)
|
|
(case frame
|
|
(:narrow (union package class)
|
|
(const limit class (object-type frame))
|
|
(<- result ((& write limit) frame limit multiname env new-value false phase)))
|
|
(:narrow (union parameter-frame local-frame)
|
|
(const m singleton-property-opt (find-local-singleton-property frame multiname write))
|
|
(when (not-in m (tag none) :narrow-true)
|
|
(write-singleton-property m new-value phase)
|
|
(<- result ok)))
|
|
(:narrow with-frame
|
|
(const value object-opt (& value frame))
|
|
(rwhen (in value (tag none) :narrow-false)
|
|
(throw-error -uninitialized-error
|
|
"cannot read a " (:character-literal "with") " statement" :apostrophe "s frame before that statement" :apostrophe
|
|
"s expression has been evaluated"))
|
|
(const limit class (object-type value))
|
|
(<- result ((& write limit) value limit multiname env new-value false phase))))
|
|
(rwhen (in result (tag ok))
|
|
(return))
|
|
(<- i (+ i 1)))
|
|
(when create-if-missing
|
|
(const pkg package (get-package-frame env))
|
|
(note "Try to write the variable into " (:local pkg) " again, this time allowing new dynamic bindings to be created dynamically.")
|
|
(const limit class (object-type pkg))
|
|
(const result (tag none ok) ((& write limit) pkg limit multiname env new-value true phase))
|
|
(rwhen (in result (tag ok))
|
|
(return)))
|
|
(throw-error -reference-error "no existing property found with the name " (:local multiname) " and one could not be created"))
|
|
|
|
|
|
(define (ordinary-write (o object) (limit class) (multiname multiname) (env environment-opt) (new-value object) (create-if-missing boolean) (phase (tag run)))
|
|
(tag none ok)
|
|
(const m-base instance-property-opt (find-base-instance-property limit multiname write))
|
|
(rwhen (not-in m-base (tag none) :narrow-true)
|
|
(write-instance-property o limit m-base new-value phase)
|
|
(return ok))
|
|
(rwhen (/= limit (object-type o) class)
|
|
(return none))
|
|
(const m property-opt (find-archetype-property o multiname write true))
|
|
(case m
|
|
(:select (tag none)
|
|
(reserve qname)
|
|
(when (and create-if-missing
|
|
(in o (union simple-instance date reg-exp package) :narrow-true)
|
|
(not (& sealed o))
|
|
(some multiname qname (= (& namespace qname) public namespace) :define-true))
|
|
(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-archetype-property o (list-set qname) read true) (tag none)))
|
|
(create-dynamic-property o qname false true new-value)
|
|
(return ok)))
|
|
(return none))
|
|
(:narrow singleton-property
|
|
(write-singleton-property m new-value phase)
|
|
(return ok))
|
|
(:narrow instance-property
|
|
(rwhen (or (not-in o class :narrow-false) (in env (tag none) :narrow-false))
|
|
(throw-error -reference-error "cannot write an instance property without supplying an instance"))
|
|
(const this object (read-implicit-this env))
|
|
(write-instance-property this (object-type this) m new-value phase)
|
|
(return ok))))
|
|
|
|
|
|
(%text :comment "The caller must make sure that the created property does not already exist and does not conflict with any other property.")
|
|
(define (create-dynamic-property (o (union simple-instance date reg-exp package)) (qname qualified-name) (sealed boolean) (enumerable boolean) (new-value object))
|
|
void
|
|
(const dv dynamic-var (new dynamic-var new-value sealed))
|
|
(&= local-bindings o (set+ (& local-bindings o) (list-set (new local-binding qname read-write false enumerable dv)))))
|
|
|
|
|
|
(define (write-instance-property (this object) (c class) (m-base instance-property) (new-value object) (phase (tag run)))
|
|
void
|
|
(const m instance-property (get-derived-instance-property c m-base write))
|
|
(case m
|
|
(:narrow instance-variable
|
|
(const s slot (find-slot this m))
|
|
(const coerced-value object (coerce new-value (&opt type m)))
|
|
(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))
|
|
(:select instance-method
|
|
(throw-error -reference-error "cannot write to an instance method"))
|
|
(:narrow instance-getter
|
|
(bottom (:local m) " cannot be an " (:type instance-getter) " because these are only represented as read-only properties."))
|
|
(:narrow instance-setter
|
|
((& call m) this new-value phase))))
|
|
|
|
|
|
(define (write-singleton-property (m singleton-property) (new-value object) (phase (tag run))) void
|
|
(case m
|
|
(:select (tag forbidden)
|
|
(throw-error -reference-error "cannot access a property defined in a scope outside the current region if any block inside the current region shadows it"))
|
|
(:narrow variable (exec (write-variable m new-value false)))
|
|
(:narrow dynamic-var
|
|
(&= value m new-value))
|
|
(:narrow getter
|
|
(bottom (:local m) " cannot be a " (:type getter) " because these are only represented as read-only properties."))
|
|
(:narrow setter
|
|
(const env environment-opt (& env m))
|
|
(assert (not-in env (tag none) :narrow-true)
|
|
"All instances are resolved for the " (:tag run) " phase, so " (:assertion) ".")
|
|
((& call m) new-value env phase))))
|
|
|
|
|
|
(%heading (2 :semantics) "Deleting")
|
|
(%text :comment "If " (:local r) " is a " (:type reference) ", " (:global-call delete-reference r) " deletes it. If "
|
|
(:local r) " is an " (:type object) ", this function signals an error in strict mode or returns " (:tag true) " in non-strict mode. "
|
|
(:global delete-reference) " is never called from a constant expression.")
|
|
(define (delete-reference (r obj-or-ref) (strict boolean) (phase (tag run))) boolean
|
|
(var result boolean-opt)
|
|
(case r
|
|
(:select object
|
|
(if strict
|
|
(throw-error -reference-error "a non-reference is not a valid target for " (:character-literal "delete") " in strict mode")
|
|
(<- result true)))
|
|
(:narrow lexical-reference
|
|
(<- result (lexical-delete (& env r) (& variable-multiname r) phase)))
|
|
(:narrow dot-reference
|
|
(<- 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)
|
|
(return result)
|
|
(return true)))
|
|
|
|
|
|
(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 (object-to-qualified-name (nth args 0) phase))
|
|
(return ((& delete limit) o limit (list-set qname) none phase)))
|
|
|
|
|
|
(define (lexical-delete (env environment) (multiname multiname) (phase (tag run))) boolean
|
|
(var i integer 0)
|
|
(while (< i (length env))
|
|
(const frame frame (nth env i))
|
|
(var result boolean-opt none)
|
|
(case frame
|
|
(:narrow (union package class)
|
|
(const limit class (object-type frame))
|
|
(<- result ((& delete limit) frame limit multiname env phase)))
|
|
(:narrow (union parameter-frame local-frame)
|
|
(when (not-in (find-local-singleton-property frame multiname write) (tag none))
|
|
(<- result false)))
|
|
(:narrow with-frame
|
|
(const value object-opt (& value frame))
|
|
(rwhen (in value (tag none) :narrow-false)
|
|
(throw-error -uninitialized-error
|
|
"cannot read a " (:character-literal "with") " statement" :apostrophe "s frame before that statement" :apostrophe
|
|
"s expression has been evaluated"))
|
|
(const limit class (object-type value))
|
|
(<- result ((& delete limit) value limit multiname env phase))))
|
|
(rwhen (not-in result (tag none) :narrow-true)
|
|
(return result))
|
|
(<- i (+ i 1)))
|
|
(return true))
|
|
|
|
|
|
(define (ordinary-delete (o object) (limit class) (multiname multiname) (env environment-opt) (phase (tag run) :unused))
|
|
boolean-opt
|
|
(rwhen (not-in (find-base-instance-property limit multiname write) (tag none))
|
|
(return false))
|
|
(rwhen (/= limit (object-type o) class)
|
|
(return none))
|
|
(const m property-opt (find-archetype-property o multiname write true))
|
|
(case m
|
|
(:select (tag none) (return none))
|
|
(:select (tag forbidden)
|
|
(throw-error -reference-error "cannot access a property defined in a scope outside the current region if any block inside the current region shadows it"))
|
|
(:select (union variable getter setter) (return false))
|
|
(:narrow dynamic-var
|
|
(cond
|
|
((& sealed m) (return false))
|
|
(nil
|
|
(&= local-bindings (assert-in o binding-object)
|
|
(map (& local-bindings (assert-in o binding-object))
|
|
b b (or (set-not-in (& qname b) multiname) (/= (& content b) m singleton-property))))
|
|
(return true))))
|
|
(:narrow instance-property
|
|
(rwhen (or (not-in o class :narrow-false) (in env (tag none) :narrow-false))
|
|
(return false))
|
|
(exec (read-implicit-this env))
|
|
(return false))))
|
|
|
|
|
|
(%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-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 (&opt enumerable m)
|
|
(<- e (set+ e (map (&opt multiname m) qname (& id qname) (= (& namespace qname) public namespace))))))
|
|
(const super class-opt (& super c))
|
|
(if (in super (tag none) :narrow-false)
|
|
(return e)
|
|
(return (set+ e (enumerate-instance-properties super)))))
|
|
|
|
|
|
(define (enumerate-archetype-properties (o object)) (list-set object)
|
|
(var e (list-set object) (list-set-of object))
|
|
(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) "Calling Instances")
|
|
(define (call (this object) (a object) (args (vector object)) (phase phase)) object
|
|
(case a
|
|
(:select (union undefined null boolean general-number char16 string namespace compound-attribute date reg-exp package)
|
|
(throw-error -type-error))
|
|
(:narrow class
|
|
(return ((& call a) this a args phase)))
|
|
(:narrow simple-instance
|
|
(const f (union (-> (object simple-instance (vector object) phase) object) (tag none)) (& call a))
|
|
(rwhen (in f (tag none) :narrow-false)
|
|
(throw-error -type-error))
|
|
(return (f this a args phase)))
|
|
(:narrow method-closure
|
|
(const m instance-method (& method a))
|
|
(return ((& call m) (& this a) args phase)))))
|
|
|
|
|
|
(define (ordinary-call (this object :unused) (c class) (args (vector object)) (phase phase :unused)) object
|
|
(note "This function can be used in a constant expression.")
|
|
(rwhen (not (& complete c))
|
|
(throw-error -constant-error "cannot call a class before its definition has been compiled"))
|
|
(rwhen (/= (length args) 1)
|
|
(throw-error -argument-error "exactly one argument must be supplied"))
|
|
(return (coerce (nth args 0) c)))
|
|
|
|
|
|
(define (same-as-construct (this object :unused) (c class) (args (vector object)) (phase phase)) object
|
|
(return (construct c args phase)))
|
|
|
|
|
|
(%heading (2 :semantics) "Creating Instances")
|
|
(define (construct (a object) (args (vector object)) (phase phase)) object
|
|
(case a
|
|
(:select (union undefined null boolean general-number char16 string namespace compound-attribute method-closure date reg-exp package)
|
|
(throw-error -type-error))
|
|
(:narrow class
|
|
(return ((& construct a) a args phase)))
|
|
(:narrow simple-instance
|
|
(const f (union (-> (simple-instance (vector object) phase) object) (tag none)) (& construct a))
|
|
(rwhen (in f (tag none) :narrow-false)
|
|
(throw-error -type-error))
|
|
(return (f a args phase)))))
|
|
|
|
|
|
(define (ordinary-construct (c class) (args (vector object)) (phase phase)) object
|
|
(rwhen (not (& complete c))
|
|
(throw-error -constant-error "cannot construct an instance of a class before its definition has been compiled"))
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "a class constructor call is not a constant expression because it evaluates to a new object each time it is evaluated"))
|
|
(const this simple-instance (create-simple-instance c (&opt prototype c) none none none))
|
|
(call-init this c args phase)
|
|
(return this))
|
|
|
|
|
|
(define (create-simple-instance (c class)
|
|
(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))
|
|
simple-instance
|
|
(var slots (list-set slot) (list-set-of slot))
|
|
(for-each (ancestors c) s
|
|
(for-each (& instance-properties s) m
|
|
(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) archetype (not (& dynamic c)) c slots call construct env)))
|
|
|
|
|
|
(define (call-init (this simple-instance) (c class-opt) (args (vector object)) (phase (tag run))) void
|
|
(var init (union (-> (simple-instance (vector object) (tag run)) void) (tag none)) none)
|
|
(when (not-in c (tag none) :narrow-true)
|
|
(<- init (& init c)))
|
|
(cond
|
|
((not-in init (tag none) :narrow-true) (init this args phase))
|
|
(nil (rwhen (nonempty args)
|
|
(throw-error -argument-error "the default constructor does not take any arguments")))))
|
|
|
|
|
|
(%heading (2 :semantics) "Adding Local Definitions")
|
|
(define (define-singleton-property (env environment) (id string) (namespaces (list-set namespace)) (override-mod override-modifier) (explicit boolean)
|
|
(accesses access-set) (m singleton-property))
|
|
multiname
|
|
(const inner-frame non-with-frame (assert-not-in (nth env 0) with-frame))
|
|
(rwhen (not-in override-mod (tag none))
|
|
(throw-error -attribute-error "a local definition cannot have the " (:character-literal "override") " attribute"))
|
|
(rwhen (and explicit (not-in inner-frame package))
|
|
(throw-error -attribute-error "the " (:character-literal "explicit") " attribute can only be used at the top level of a package"))
|
|
(var namespaces2 (list-set namespace) namespaces)
|
|
(when (empty namespaces2)
|
|
(<- namespaces2 (list-set public)))
|
|
(const multiname multiname (map namespaces2 ns (new qualified-name ns id)))
|
|
(const regional-env (vector frame) (get-regional-environment env))
|
|
(rwhen (some (& local-bindings inner-frame) b (and (set-in (& qname b) multiname) (accesses-overlap (& accesses b) accesses)))
|
|
(throw-error -definition-error "duplicate definition in the same scope"))
|
|
(rwhen (and (in inner-frame class :narrow-true) (= id (& name inner-frame) string))
|
|
(throw-error -definition-error "a " (:character-literal "static") " property of a class cannot have the same name as the class, regardless of the namespace"))
|
|
(for-each (subseq regional-env 1) frame
|
|
(rwhen (and (not-in frame with-frame :narrow-true)
|
|
(some (& local-bindings frame) b (and (set-in (& qname b) multiname) (accesses-overlap (& accesses b) accesses)
|
|
(not-in (& content b) (tag forbidden)))))
|
|
(throw-error -definition-error "this definition would shadow a property defined in an outer scope within the same region")))
|
|
(const new-bindings (list-set local-binding) (map multiname qname (new local-binding qname accesses explicit true m)))
|
|
(&= local-bindings inner-frame (set+ (& local-bindings inner-frame) new-bindings))
|
|
(note "Mark the bindings of " (:local multiname) " as " (:tag forbidden)
|
|
" in all non-innermost frames in the current region if they haven" :apostrophe "t been marked as such already.")
|
|
(const new-forbidden-bindings (list-set local-binding) (map multiname qname (new local-binding qname accesses true true forbidden)))
|
|
(for-each (subseq regional-env 1) frame
|
|
(assert (not-in frame class) "Since " (:assertion) " here, a " (:type class) " frame never gets a " (:tag forbidden) " binding.")
|
|
(when (not-in frame with-frame :narrow-true)
|
|
(&= local-bindings frame (set+ (& local-bindings frame) new-forbidden-bindings))))
|
|
(return multiname))
|
|
|
|
|
|
(%text :comment (:global-call define-hoisted-var env id initial-value) " defines a hoisted variable with the name " (:local id)
|
|
" in the environment " (:local env) ". Hoisted variables are hoisted to the package or enclosing function scope. "
|
|
"Multiple hoisted variables may be defined in the same scope, but they may not coexist with non-hoisted variables with the same name. "
|
|
"A hoisted variable can be defined using either a " (:character-literal "var") " or a " (:character-literal "function") " statement. "
|
|
"If it is defined using " (:character-literal "var") ", then " (:local initial-value) " is always " (:tag undefined)
|
|
" (if the " (:character-literal "var") " statement has an initialiser, then the variable" :apostrophe "s value will be written later when the "
|
|
(:character-literal "var") " statement is executed). "
|
|
"If it is defined using " (:character-literal "function") ", then " (:local initial-value) " must be a function instance or open instance. "
|
|
"A " (:character-literal "var") " hoisted variable may be hoisted into the " (:type parameter-frame)
|
|
" if there is already a parameter with the same name; a " (:character-literal "function") " hoisted variable is never hoisted into the "
|
|
(:type parameter-frame) " and will shadow a parameter with the same name for compatibility with ECMAScript Edition 3. "
|
|
"If there are multiple " (:character-literal "function") " definitions, the initial value is the last " (:character-literal "function") " definition.")
|
|
(define (define-hoisted-var (env environment) (id string) (initial-value (union object uninstantiated-function))) dynamic-var
|
|
(const qname qualified-name (new qualified-name public id))
|
|
(const regional-env (vector frame) (get-regional-environment env))
|
|
(var regional-frame frame (nth regional-env (- (length regional-env) 1)))
|
|
(assert (in regional-frame (union package parameter-frame) :narrow-true)
|
|
(:local env) " is either a " (:type package) " or a " (:type parameter-frame)
|
|
" because hoisting only occurs into package or function scope.")
|
|
(var existing-bindings (list-set local-binding) (map (& local-bindings regional-frame) b b (= (& qname b) qname qualified-name)))
|
|
(when (and (or (empty existing-bindings) (not-in initial-value (tag undefined)))
|
|
(in regional-frame parameter-frame) (>= (length regional-env) 2))
|
|
(<- regional-frame (nth regional-env (- (length regional-env) 2)) :end-narrow)
|
|
(<- existing-bindings (map (& local-bindings (assert-in regional-frame local-frame)) b b (= (& qname b) qname qualified-name))))
|
|
(cond
|
|
((empty existing-bindings)
|
|
(const v dynamic-var (new dynamic-var initial-value true))
|
|
(&= local-bindings regional-frame (set+ (& local-bindings regional-frame) (list-set (new local-binding qname read-write false true v))))
|
|
(return v))
|
|
((/= (length existing-bindings) 1)
|
|
(throw-error -definition-error "a hoisted definition conflicts with a non-hoisted one"))
|
|
(nil
|
|
(const b local-binding (unique-elt-of existing-bindings))
|
|
(const m singleton-property (& content b))
|
|
(rwhen (or (not-in (& accesses b) (tag read-write)) (not-in m dynamic-var :narrow-false))
|
|
(throw-error -definition-error "a hoisted definition conflicts with a non-hoisted one"))
|
|
(note "At this point a hoisted binding of the same " (:character-literal "var") " already exists, so there is no need to create another one. "
|
|
"Overwrite its initial value if the new definition is a " (:character-literal "function") " definition.")
|
|
(when (not-in initial-value (tag undefined))
|
|
(&= value m initial-value))
|
|
(&= sealed m true)
|
|
(&= local-bindings regional-frame (set- (& local-bindings regional-frame) (list-set b)))
|
|
(&= local-bindings regional-frame (set+ (& local-bindings regional-frame) (list-set (set-field b enumerable true))))
|
|
(return m))))
|
|
|
|
|
|
(%heading (2 :semantics) "Adding Instance Definitions")
|
|
|
|
(define (search-for-overrides (c class) (multiname multiname) (accesses access-set)) instance-property-opt
|
|
(var m-base instance-property-opt none)
|
|
(const s class-opt (& super c))
|
|
(when (not-in s (tag none) :narrow-true)
|
|
(for-each multiname qname
|
|
(const m instance-property-opt (find-base-instance-property s (list-set qname) accesses))
|
|
(cond
|
|
((in m-base (tag none) :narrow-false) (<- m-base m))
|
|
((and (not-in m (tag none) :narrow-true) (/= m m-base instance-property))
|
|
(throw-error -definition-error "cannot override two separate superclass methods at the same time")))))
|
|
(return m-base))
|
|
|
|
|
|
(define (define-instance-property (c class) (cxt context) (id string) (namespaces (list-set namespace))
|
|
(override-mod override-modifier) (explicit boolean) (m instance-property))
|
|
instance-property-opt
|
|
(rwhen explicit
|
|
(throw-error -attribute-error "the " (:character-literal "explicit") " attribute can only be used at the top level of a package"))
|
|
(const accesses access-set (instance-property-accesses m))
|
|
(const requested-multiname multiname (map namespaces ns (new qualified-name ns id)))
|
|
(const open-multiname multiname (map (& open-namespaces cxt) ns (new qualified-name ns id)))
|
|
(var defined-multiname multiname)
|
|
(var searched-multiname multiname)
|
|
(cond
|
|
((empty requested-multiname)
|
|
(<- defined-multiname (list-set (new qualified-name public id)))
|
|
(<- searched-multiname open-multiname)
|
|
(assert (set<= defined-multiname searched-multiname multiname) (:assertion) " because the " (:character-literal "public") " namespace is always open."))
|
|
(nil
|
|
(<- defined-multiname requested-multiname)
|
|
(<- searched-multiname requested-multiname)))
|
|
(const m-base instance-property-opt (search-for-overrides c searched-multiname accesses))
|
|
(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))
|
|
(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)
|
|
(case m
|
|
(:select instance-variable (<- good-kind (in m-overridden instance-variable)))
|
|
(:select instance-getter (<- good-kind (in m-overridden (union instance-variable instance-getter))))
|
|
(:select instance-setter (<- good-kind (in m-overridden (union instance-variable instance-setter))))
|
|
(:select instance-method (<- good-kind (in m-overridden instance-method))))
|
|
(rwhen (not good-kind)
|
|
(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 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"))
|
|
(case override-mod
|
|
(:select (tag none)
|
|
(rwhen (not-in m-base (tag none))
|
|
(throw-error -definition-error
|
|
"a definition that overrides a superclass" :apostrophe "s property must be marked with the " (:character-literal "override") " attribute"))
|
|
(rwhen (not-in (search-for-overrides c open-multiname accesses) (tag none))
|
|
(throw-error -definition-error
|
|
"this definition is hidden by one in a superclass when accessed without a namespace qualifier; "
|
|
"in the rare cases where this is intentional, use the " (:character-literal "override(false)") " attribute")))
|
|
(:select (tag false)
|
|
(rwhen (not-in m-base (tag none))
|
|
(throw-error -definition-error
|
|
"this definition is marked with " (:character-literal "override(false)") " but it overrides a superclass" :apostrophe "s property")))
|
|
(:select (tag true)
|
|
(rwhen (in m-base (tag none))
|
|
(throw-error -definition-error
|
|
"this definition is marked with " (:character-literal "override") " or " (:character-literal "override(true)")
|
|
" but it doesn" :apostrophe "t override a superclass" :apostrophe "s property")))
|
|
(:select (tag undefined)))
|
|
(&const= multiname m defined-multiname)
|
|
(&= instance-properties c (set+ (& instance-properties c) (list-set m)))
|
|
(return m-overridden))
|
|
|
|
|
|
(%heading (2 :semantics) "Instantiation")
|
|
|
|
(define (instantiate-function (uf uninstantiated-function) (env environment)) simple-instance
|
|
(const c class (& type uf))
|
|
(const i simple-instance (create-simple-instance c (&opt prototype c) (& call uf) (& construct uf) env))
|
|
(dot-write i (list-set (new qualified-name public "length")) (real-to-float64 (& length uf)) run)
|
|
(when (= c -prototype-function class)
|
|
(const prototype object (construct -object (vector-of object) run))
|
|
(dot-write prototype (list-set (new qualified-name public "constructor")) i run)
|
|
(dot-write i (list-set (new qualified-name public "prototype")) prototype run))
|
|
(const instantiations (list-set simple-instance) (& instantiations uf))
|
|
(when (nonempty instantiations)
|
|
(// (:def-const i2 simple-instance) "Suppose that " (:global instantiate-function) " were to choose at its discretion some element " (:local i2) " of "
|
|
(:local instantiations) ", assign " (:expr environment-opt (& env i2)) :nbsp :assign-10 :nbsp (:local env) ", and return " (:local i) ". "
|
|
"If the behaviour of doing that assignment were observationally indistinguishable by the rest of the program from the behaviour of "
|
|
"returning " (:local i) " without modifying " (:expr environment-opt (& env i2)) ", then the implementation may, but does not have to, "
|
|
(:keyword return) :nbsp (:local i2) " now, discarding (or not even bothering to create) the value of " (:local i) ".")
|
|
(note "The above rule allows an implementation to avoid creating a fresh closure each time a local function is instantiated if it can show that the "
|
|
"closures would behave identically. This optimisation is not transparent to the programmer because the instantiations will be "
|
|
(:character-literal "===") " to each other and share one set of "
|
|
"properties (including the " (:character-literal "prototype") " property, if applicable) rather than each having its own. ECMAScript programs "
|
|
"should not rely on this distinction."))
|
|
(&= instantiations uf (set+ instantiations (list-set i)))
|
|
(return i))
|
|
|
|
|
|
(define (instantiate-property (m singleton-property) (env environment)) singleton-property
|
|
(case m
|
|
(:select (tag forbidden) (return m))
|
|
(:narrow variable
|
|
(assert (in (& setup m) (tag none))
|
|
(:assertion) " because " (:action setup) " must have been called on a frame before that frame can be instantiated.")
|
|
(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 (& initializer m) env)))
|
|
(:narrow dynamic-var
|
|
(var value (union object uninstantiated-function) (& value m))
|
|
(when (in value uninstantiated-function :narrow-true)
|
|
(<- value (instantiate-function value env) :end-narrow))
|
|
(return (new dynamic-var value (& sealed m))))
|
|
(:narrow getter
|
|
(case (& env m)
|
|
(:select environment (return m))
|
|
(:select (tag none) (return (new getter (& call m) env)))))
|
|
(:narrow setter
|
|
(case (& env m)
|
|
(:select environment (return m))
|
|
(:select (tag none) (return (new setter (& call m) env)))))))
|
|
|
|
|
|
(deftuple property-translation
|
|
(from singleton-property)
|
|
(to singleton-property))
|
|
|
|
(define (instantiate-local-frame (frame local-frame) (env environment))
|
|
local-frame
|
|
(const instantiated-frame local-frame (new local-frame (list-set-of local-binding)))
|
|
(const properties (list-set singleton-property)
|
|
(map (& local-bindings frame) b (& content b)))
|
|
(const property-translations (list-set property-translation)
|
|
(map properties m (new property-translation m (instantiate-property m (cons instantiated-frame env)))))
|
|
(function (translate-property (m singleton-property)) singleton-property
|
|
(const mi property-translation (unique-elt-of property-translations mi (= (& from mi) m singleton-property)))
|
|
(return (& to mi)))
|
|
(&= local-bindings instantiated-frame (map (& local-bindings frame) b (set-field b content (translate-property (& content b)))))
|
|
(return instantiated-frame))
|
|
|
|
|
|
(define (instantiate-parameter-frame (frame parameter-frame) (env environment) (singular-this object-opt))
|
|
parameter-frame
|
|
(assert (= (& superconstructor-called frame) (not-in (& kind frame) (tag constructor-function)) boolean)
|
|
(:expr boolean (& superconstructor-called frame)) " must be " (:tag true) " if and only if "
|
|
(:expr function-kind (& kind frame)) " is not " (:tag constructor-function) ".")
|
|
(const instantiated-frame parameter-frame (new parameter-frame (list-set-of local-binding) (& kind frame) (& handling frame)
|
|
(& calls-superconstructor frame) (& superconstructor-called frame)
|
|
singular-this :uninit :uninit (&opt return-type frame)))
|
|
(note (:local properties) " will contain the set of all " (:type singleton-property) " records found in the " (:local frame) ".")
|
|
(var properties (list-set singleton-property)
|
|
(map (& local-bindings frame) b (& content b)))
|
|
(note "If any of the parameters (including the rest parameter) are anonymous, their bindings will not be present in "
|
|
(:expr (list-set local-binding) (& local-bindings frame)) ". In this situation, the following steps add their "
|
|
(:type singleton-property) " records to " (:local properties) ".")
|
|
(for-each (&opt parameters frame) p
|
|
(<- properties (set+ properties (list-set-of singleton-property (& var p)))))
|
|
(const rest variable-opt (&opt rest frame))
|
|
(when (not-in rest (tag none) :narrow-true)
|
|
(<- properties (set+ properties (list-set-of singleton-property rest))))
|
|
(const property-translations (list-set property-translation)
|
|
(map properties m (new property-translation m (instantiate-property m (cons instantiated-frame env)))))
|
|
(function (translate-property (m singleton-property)) singleton-property
|
|
(const mi property-translation (unique-elt-of property-translations mi (= (& from mi) m singleton-property)))
|
|
(return (& to mi)))
|
|
(&= local-bindings instantiated-frame (map (& local-bindings frame) b (set-field b content (translate-property (& content b)))))
|
|
(&= parameters instantiated-frame (map (&opt parameters frame) op
|
|
(new parameter (assert-in (translate-property (& var op)) (union variable dynamic-var)) (& default op))))
|
|
(if (in rest (tag none) :narrow-false)
|
|
(&= rest instantiated-frame none)
|
|
(&= rest instantiated-frame (assert-in (translate-property rest) variable)))
|
|
(return instantiated-frame))
|
|
|
|
|
|
|
|
(%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
|
|
(rwhen (>= n (length args))
|
|
(return default))
|
|
(const arg object (nth args n))
|
|
(if (in arg (tag undefined))
|
|
(return default)
|
|
(return arg)))
|
|
|
|
|
|
(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-var-binding (qname qualified-name) (type (delay class)) (value object)) local-binding
|
|
(return (new local-binding
|
|
qname read-write false false
|
|
(new variable type value false 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))))
|
|
|
|
|
|
(%text :comment (:global-call std-reserve qname archetype) " is used during the creation of system objects. It returns an alias of the local binding of "
|
|
(:local qname) " in " (:local archetype)
|
|
", which should be the archetype of the object being created. The alias that " (:global std-reserve) " defines serves to prevent " (:local qname)
|
|
" from being later redefined by users in the object being created while at the same time retaining the definition of " (:local qname)
|
|
" that would normally be inherited from " (:local archetype) ".")
|
|
(define (std-reserve (qname qualified-name) (archetype simple-instance)) local-binding
|
|
(const matching-bindings (list-set local-binding) (map (& local-bindings archetype) b b (= (& qname b) qname qualified-name)))
|
|
(return (unique-elt-of matching-bindings)))
|
|
|
|
|
|
|
|
(%heading 1 "Expressions")
|
|
(grammar-argument :beta allow-in no-in)
|
|
|
|
|
|
(%heading (2 :semantics) "Terminal Actions")
|
|
|
|
(declare-action name $identifier string :action nil
|
|
(terminal-action name $identifier identity))
|
|
(declare-action value $number general-number :action nil
|
|
(terminal-action value $number identity))
|
|
(declare-action value $string string :action nil
|
|
(terminal-action value $string identity))
|
|
(declare-action body $regular-expression string :action nil
|
|
(terminal-action body $regular-expression first))
|
|
(declare-action flags $regular-expression string :action nil
|
|
(terminal-action flags $regular-expression second))
|
|
(%print-actions)
|
|
|
|
|
|
(%heading 2 "Identifiers")
|
|
(rule :identifier ((name string))
|
|
(production :identifier ($identifier) identifier-identifier (name (name $identifier)))
|
|
(production :identifier (get) identifier-get (name "get"))
|
|
(production :identifier (set) identifier-set (name "set"))
|
|
(? js2 (production :identifier (include) identifier-include (name "include"))))
|
|
(%print-actions)
|
|
|
|
(%heading 2 "Qualified Identifiers")
|
|
(rule :simple-qualified-identifier ((open-namespaces (writable-cell (list-set namespace)))
|
|
(strict (writable-cell boolean))
|
|
(validate (-> (context environment) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment phase) multiname)))
|
|
(production :simple-qualified-identifier (:identifier) simple-qualified-identifier-identifier
|
|
((validate cxt (env :unused))
|
|
(action<- (open-namespaces :simple-qualified-identifier 0) (& open-namespaces cxt))
|
|
(action<- (strict :simple-qualified-identifier 0) (& strict cxt)))
|
|
((setup))
|
|
((eval (env :unused) (phase :unused))
|
|
(return (map (open-namespaces :simple-qualified-identifier 0) ns (new qualified-name ns (name :identifier))))))
|
|
(production :simple-qualified-identifier (:identifier \:\: :identifier) simple-qualified-identifier-identifier-qualifier
|
|
((validate cxt (env :unused))
|
|
(action<- (open-namespaces :simple-qualified-identifier 0) (& open-namespaces cxt)))
|
|
((setup))
|
|
((eval env phase)
|
|
(const multiname multiname (map (open-namespaces :simple-qualified-identifier 0) ns (new qualified-name ns (name :identifier 1))))
|
|
(const a object (lexical-read env multiname phase))
|
|
(rwhen (not-in a namespace :narrow-false)
|
|
(throw-error -type-error "the qualifier must be a namespace"))
|
|
(return (list-set (new qualified-name a (name :identifier 2))))))
|
|
(production :simple-qualified-identifier (:reserved-namespace \:\: :identifier) simple-qualified-identifier-reserved-namespace-qualifier
|
|
((validate cxt env) ((validate :reserved-namespace) cxt env))
|
|
((setup) ((setup :reserved-namespace)))
|
|
((eval env phase)
|
|
(const q namespace ((eval :reserved-namespace) env phase))
|
|
(return (list-set (new qualified-name q (name :identifier)))))))
|
|
|
|
(rule :expression-qualified-identifier ((strict (writable-cell boolean))
|
|
(validate (-> (context environment) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment phase) multiname)))
|
|
(production :expression-qualified-identifier (:paren-expression \:\: :identifier) expression-qualified-identifier-identifier
|
|
((validate cxt env)
|
|
(action<- (strict :expression-qualified-identifier 0) (& strict cxt))
|
|
((validate :paren-expression) cxt env))
|
|
((setup) ((setup :paren-expression)))
|
|
((eval env phase)
|
|
(const q object (read-reference ((eval :paren-expression) env phase) phase))
|
|
(rwhen (not-in q namespace :narrow-false) (throw-error -type-error "the qualifier must be a namespace"))
|
|
(return (list-set (new qualified-name q (name :identifier)))))))
|
|
|
|
(rule :qualified-identifier ((strict (writable-cell boolean))
|
|
(validate (-> (context environment) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment phase) multiname)))
|
|
(production :qualified-identifier (:simple-qualified-identifier) qualified-identifier-simple
|
|
((validate cxt env)
|
|
(action<- (strict :qualified-identifier 0) (& strict cxt))
|
|
((validate :simple-qualified-identifier) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase) :forward-result))
|
|
(production :qualified-identifier (:expression-qualified-identifier) qualified-identifier-expression
|
|
((validate cxt env)
|
|
(action<- (strict :qualified-identifier 0) (& strict cxt))
|
|
((validate :expression-qualified-identifier) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase) :forward-result)))
|
|
(%print-actions ("Validation" open-namespaces strict validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Primary Expressions")
|
|
(rule :primary-expression ((validate (-> (context environment) void)) (setup (-> () void)) (eval (-> (environment phase) obj-or-ref)))
|
|
(production :primary-expression (null) primary-expression-null
|
|
((validate (cxt :unused) (env :unused)))
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return null)))
|
|
(production :primary-expression (true) primary-expression-true
|
|
((validate (cxt :unused) (env :unused)))
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return true)))
|
|
(production :primary-expression (false) primary-expression-false
|
|
((validate (cxt :unused) (env :unused)))
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return false)))
|
|
(production :primary-expression ($number) primary-expression-number
|
|
((validate (cxt :unused) (env :unused)))
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return (value $number))))
|
|
(production :primary-expression ($string) primary-expression-string
|
|
((validate (cxt :unused) (env :unused)))
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return (value $string))))
|
|
(production :primary-expression (this) primary-expression-this
|
|
((validate cxt env)
|
|
(const frame parameter-frame-opt (get-enclosing-parameter-frame env))
|
|
(cond
|
|
((in frame (tag none) :narrow-false)
|
|
(rwhen (& strict cxt)
|
|
(throw-error -syntax-error (:character-literal "this") " can be used outside a function only in non-strict mode")))
|
|
((in (& kind frame) (tag plain-function))
|
|
(throw-error -syntax-error "this function does not define " (:character-literal "this")))))
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const frame parameter-frame-opt (get-enclosing-parameter-frame env))
|
|
(rwhen (in frame (tag none) :narrow-false)
|
|
(return (get-package-frame env)))
|
|
(assert (not-in (& kind frame) (tag plain-function))
|
|
(:action validate) " ensured that " (:assertion) " at this point.")
|
|
(const this object-opt (& this frame))
|
|
(rwhen (in this (tag none) :narrow-false)
|
|
(assert (in phase (tag compile)) "If " (:action validate) " passed, " (:local this) " can be uninitialised only when " (:assertion) ".")
|
|
(throw-error -constant-error "a constant expression cannot read an uninitialised " (:local this) " parameter"))
|
|
(rwhen (not (& superconstructor-called frame))
|
|
(throw-error -uninitialized-error "can" :apostrophe "t access " (:character-literal "this") " from within a constructor before the superconstructor has been called"))
|
|
(return this)))
|
|
(production :primary-expression ($regular-expression) primary-expression-regular-expression
|
|
((validate (cxt :unused) (env :unused)))
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return (append (body $regular-expression) "#" (flags $regular-expression))))) ;*****
|
|
(production :primary-expression (:reserved-namespace) primary-expression-reserved-namespace
|
|
((validate cxt env) ((validate :reserved-namespace) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :reserved-namespace) env phase))))
|
|
(production :primary-expression (:paren-list-expression) primary-expression-paren-list-expression
|
|
((validate cxt env) ((validate :paren-list-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :paren-list-expression) env phase))))
|
|
(production :primary-expression (:array-literal) primary-expression-array-literal
|
|
((validate cxt env) ((validate :array-literal) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :array-literal) env phase))))
|
|
(production :primary-expression (:object-literal) primary-expression-object-literal
|
|
((validate cxt env) ((validate :object-literal) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :object-literal) env phase))))
|
|
(production :primary-expression (:function-expression) primary-expression-function-expression
|
|
((validate cxt env) ((validate :function-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :function-expression) env phase)))))
|
|
|
|
(rule :reserved-namespace ((validate (-> (context environment) void)) (setup (-> () void)) (eval (-> (environment phase) namespace)))
|
|
(production :reserved-namespace (public) reserved-namespace-public
|
|
((validate (cxt :unused) (env :unused)))
|
|
((setup))
|
|
((eval (env :unused) (phase :unused)) (return public)))
|
|
(production :reserved-namespace (private) reserved-namespace-private
|
|
((validate (cxt :unused) env)
|
|
(rwhen (in (get-enclosing-class env) (tag none))
|
|
(throw-error -syntax-error (:character-literal "private") " is meaningful only inside a class")))
|
|
((setup))
|
|
((eval env (phase :unused))
|
|
(const c class-opt (get-enclosing-class env))
|
|
(assert (not-in c (tag none) :narrow-true)
|
|
(:action validate) " already ensured that " (:assertion) ".")
|
|
(return (&opt private-namespace c)))))
|
|
|
|
(rule :paren-expression ((validate (-> (context environment) void)) (setup (-> () void)) (eval (-> (environment phase) obj-or-ref)))
|
|
(production :paren-expression (\( (:assignment-expression allow-in) \)) paren-expression-assignment-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) :forward-result)))
|
|
|
|
(rule :paren-list-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref))
|
|
(eval-as-list (-> (environment phase) (vector object))))
|
|
(production :paren-list-expression (:paren-expression) paren-list-expression-paren-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :paren-expression) env phase)))
|
|
((eval-as-list env phase)
|
|
(const elt object (read-reference ((eval :paren-expression) env phase) phase))
|
|
(return (vector elt))))
|
|
(production :paren-list-expression (\( (:list-expression allow-in) \, (:assignment-expression allow-in) \)) paren-list-expression-list-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(exec (read-reference ((eval :list-expression) env phase) phase))
|
|
(return (read-reference ((eval :assignment-expression) env phase) phase)))
|
|
((eval-as-list env phase)
|
|
(const elts (vector object) ((eval-as-list :list-expression) env phase))
|
|
(const elt object (read-reference ((eval :assignment-expression) env phase) phase))
|
|
(return (append elts (vector elt))))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Function Expressions")
|
|
(rule :function-expression ((f (writable-cell uninstantiated-function))
|
|
(validate (-> (context environment) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :function-expression (function :function-common) function-expression-anonymous
|
|
((validate cxt env)
|
|
(var kind static-function-kind plain-function)
|
|
(when (and (not (& strict cxt)) (plain :function-common))
|
|
(<- kind unchecked-function))
|
|
(action<- (f :function-expression 0) ((validate-static-function :function-common) cxt env kind)))
|
|
((setup) ((setup :function-common)))
|
|
((eval env phase)
|
|
(rwhen (in phase (tag compile))
|
|
(throw-error -constant-error "a " (:character-literal "function") " expression is not a constant expression because it can evaluate to different values"))
|
|
(return (instantiate-function (f :function-expression 0) env))))
|
|
(production :function-expression (function :identifier :function-common) function-expression-named
|
|
((validate cxt env)
|
|
(const v variable (new variable -function none true none busy :uninit))
|
|
(const b local-binding (new local-binding (new qualified-name public (name :identifier)) read-write false true v))
|
|
(const compile-frame local-frame (new local-frame (list-set b)))
|
|
(var kind static-function-kind plain-function)
|
|
(when (and (not (& strict cxt)) (plain :function-common))
|
|
(<- kind unchecked-function))
|
|
(action<- (f :function-expression 0) ((validate-static-function :function-common) cxt (cons compile-frame env) kind)))
|
|
((setup) ((setup :function-common)))
|
|
((eval env phase)
|
|
(rwhen (in phase (tag compile))
|
|
(throw-error -constant-error "a " (:character-literal "function") " expression is not a constant expression because it can evaluate to different values"))
|
|
(const v variable (new variable -function none true none none :uninit))
|
|
(const b local-binding (new local-binding (new qualified-name public (name :identifier)) read-write false true v))
|
|
(const runtime-frame local-frame (new local-frame (list-set b)))
|
|
(const f simple-instance (instantiate-function (f :function-expression 0) (cons runtime-frame env)))
|
|
(&= value v f)
|
|
(return f))))
|
|
(%print-actions ("Validation" f validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Object Literals")
|
|
(rule :object-literal ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :object-literal (\{ :field-list \}) object-literal-list
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "an object literal is not a constant expression because it evaluates to a new object each time it is evaluated"))
|
|
(const o object (construct -object (vector-of object) phase))
|
|
((eval :field-list) env o phase)
|
|
(return o))))
|
|
|
|
|
|
(rule :field-list ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment object (tag run)) void)))
|
|
(production :field-list () field-list-empty
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env o phase) :forward))
|
|
(production :field-list (:nonempty-field-list) field-list-nonempty
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env o phase) :forward)))
|
|
|
|
|
|
(rule :nonempty-field-list ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment object (tag run)) void)))
|
|
(production :nonempty-field-list (:literal-field) nonempty-field-list-one
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env o phase) :forward))
|
|
(production :nonempty-field-list (:literal-field \, :nonempty-field-list) nonempty-field-list-more
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env o phase) :forward)))
|
|
|
|
|
|
(rule :literal-field ((validate (-> (context environment) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment object (tag run)) void)))
|
|
(production :literal-field (:field-name \: (:assignment-expression allow-in)) literal-field-assignment-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env o phase)
|
|
(const multiname multiname ((eval :field-name) env phase))
|
|
(const value object (read-reference ((eval :assignment-expression) env phase) phase))
|
|
(dot-write o multiname value phase))))
|
|
|
|
|
|
(rule :field-name ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) multiname)))
|
|
(production :field-name (:qualified-identifier) field-name-identifier
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :qualified-identifier) env phase))))
|
|
(production :field-name ($string) field-name-string
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((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 (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 (object-to-qualified-name a phase))))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Array Literals")
|
|
(rule :array-literal ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :array-literal ([ :element-list ]) array-literal-list
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "an array literal is not a constant expression because it evaluates to a new object each time it is evaluated"))
|
|
(const o object (construct -array (vector-of object) phase))
|
|
(const length integer ((eval :element-list) env 0 o phase))
|
|
(write-array-private-length o length phase)
|
|
(return o))))
|
|
|
|
|
|
(rule :element-list ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment integer object (tag run)) integer)))
|
|
(production :element-list () element-list-none
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) length (o :unused) (phase :unused)) (return length)))
|
|
(production :element-list (:literal-element) element-list-one
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env length o phase)
|
|
((eval :literal-element) env length o phase)
|
|
(return (+ length 1))))
|
|
(production :element-list (\, :element-list) element-list-hole
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env length o phase)
|
|
(return ((eval :element-list) env (+ length 1) o phase))))
|
|
(production :element-list (:literal-element \, :element-list) element-list-more
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env length o phase)
|
|
((eval :literal-element) env length o phase)
|
|
(return ((eval :element-list) env (+ length 1) o phase)))))
|
|
|
|
|
|
(rule :literal-element ((validate (-> (context environment) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment integer object (tag run)) void)))
|
|
(production :literal-element ((:assignment-expression allow-in)) literal-element-assignment-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env length o phase)
|
|
(const value object (read-reference ((eval :assignment-expression) env phase) phase))
|
|
(index-write o length value phase))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Super Expressions")
|
|
(rule :super-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-optional-limit)))
|
|
(production :super-expression (super) super-expression-super
|
|
((validate (cxt :unused) env)
|
|
(const c class-opt (get-enclosing-class env))
|
|
(rwhen (in c (tag none) :narrow-false)
|
|
(throw-error -syntax-error "a " (:character-literal "super") " expression is meaningful only inside a class"))
|
|
(const frame parameter-frame-opt (get-enclosing-parameter-frame env))
|
|
(rwhen (or (in frame (tag none) :narrow-false) (in (& kind frame) static-function-kind))
|
|
(throw-error -syntax-error "a " (:character-literal "super") " expression without an argument is meaningful only inside an instance method or a constructor"))
|
|
(rwhen (in (& super c) (tag none))
|
|
(throw-error -syntax-error "a " (:character-literal "super") " expression is meaningful only if the enclosing class has a superclass")))
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const frame parameter-frame-opt (get-enclosing-parameter-frame env))
|
|
(assert (and (not-in frame (tag none) :narrow-true) (not-in (& kind frame) static-function-kind))
|
|
(:action validate) " ensured that " (:assertion) " at this point.")
|
|
(const this object-opt (& this frame))
|
|
(rwhen (in this (tag none) :narrow-false)
|
|
(assert (in phase (tag compile)) "If " (:action validate) " passed, " (:local this) " can be uninitialised only when " (:assertion) ".")
|
|
(throw-error -constant-error "a constant expression cannot read an uninitialised " (:local this) " parameter"))
|
|
(rwhen (not (& superconstructor-called frame))
|
|
(throw-error -uninitialized-error "can" :apostrophe "t access " (:character-literal "super") " from within a constructor before the superconstructor has been called"))
|
|
(return (make-limited-instance this (assert-not-in (get-enclosing-class env) (tag none)) phase))))
|
|
(production :super-expression (super :paren-expression) super-expression-super-paren-expression
|
|
((validate cxt env)
|
|
(const c class-opt (get-enclosing-class env))
|
|
(rwhen (in c (tag none) :narrow-false)
|
|
(throw-error -syntax-error "a " (:character-literal "super") " expression is meaningful only inside a class"))
|
|
(rwhen (in (& super c) (tag none))
|
|
(throw-error -syntax-error "a " (:character-literal "super") " expression is meaningful only if the enclosing class has a superclass"))
|
|
((validate :paren-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const r obj-or-ref ((eval :paren-expression) env phase))
|
|
(return (make-limited-instance r (assert-not-in (get-enclosing-class env) (tag none)) phase)))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(define (make-limited-instance (r obj-or-ref) (c class) (phase phase)) obj-optional-limit
|
|
(const o object (read-reference r phase))
|
|
(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 (coerce o limit))
|
|
(rwhen (in coerced (tag null))
|
|
(return null))
|
|
(return (new limited-instance coerced limit)))
|
|
|
|
|
|
(%heading 2 "Postfix Expressions")
|
|
(rule :postfix-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :postfix-expression (:attribute-expression) postfix-expression-attribute-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) :forward-result))
|
|
(production :postfix-expression (:full-postfix-expression) postfix-expression-full-postfix-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) :forward-result))
|
|
(production :postfix-expression (:short-new-expression) postfix-expression-short-new-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) :forward-result)))
|
|
|
|
(rule :attribute-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :attribute-expression (:simple-qualified-identifier) attribute-expression-simple-qualified-identifier
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const m multiname ((eval :simple-qualified-identifier) env phase))
|
|
(return (new lexical-reference env m (strict :simple-qualified-identifier)))))
|
|
(production :attribute-expression (:attribute-expression :property-operator) attribute-expression-property-operator
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :attribute-expression) env phase) phase))
|
|
(return ((eval :property-operator) env a phase))))
|
|
(production :attribute-expression (:attribute-expression :arguments) attribute-expression-call
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const r obj-or-ref ((eval :attribute-expression) env phase))
|
|
(const f object (read-reference r phase))
|
|
(var base object)
|
|
(case r
|
|
(:select (union object lexical-reference) (<- base null))
|
|
(:narrow (union dot-reference bracket-reference) (<- base (& base r))))
|
|
(const args (vector object) ((eval :arguments) env phase))
|
|
(return (call base f args phase)))))
|
|
|
|
(rule :full-postfix-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :full-postfix-expression (:primary-expression) full-postfix-expression-primary-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :primary-expression) env phase))))
|
|
(production :full-postfix-expression (:expression-qualified-identifier) full-postfix-expression-expression-qualified-identifier
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const m multiname ((eval :expression-qualified-identifier) env phase))
|
|
(return (new lexical-reference env m (strict :expression-qualified-identifier)))))
|
|
(production :full-postfix-expression (:full-new-expression) full-postfix-expression-full-new-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :full-new-expression) env phase))))
|
|
(production :full-postfix-expression (:full-postfix-expression :property-operator) full-postfix-expression-property-operator
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :full-postfix-expression) env phase) phase))
|
|
(return ((eval :property-operator) env a phase))))
|
|
(production :full-postfix-expression (:super-expression :property-operator) full-postfix-expression-super-property-operator
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a obj-optional-limit ((eval :super-expression) env phase))
|
|
(return ((eval :property-operator) env a phase))))
|
|
(production :full-postfix-expression (:full-postfix-expression :arguments) full-postfix-expression-call
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const r obj-or-ref ((eval :full-postfix-expression) env phase))
|
|
(const f object (read-reference r phase))
|
|
(var base object)
|
|
(case r
|
|
(:select (union object lexical-reference) (<- base null))
|
|
(:narrow (union dot-reference bracket-reference) (<- base (& base r))))
|
|
(const args (vector object) ((eval :arguments) env phase))
|
|
(return (call base f args phase))))
|
|
(production :full-postfix-expression (:postfix-expression :no-line-break ++) full-postfix-expression-increment
|
|
((validate cxt env) :forward)
|
|
((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"))
|
|
(const r obj-or-ref ((eval :postfix-expression) env phase))
|
|
(const a object (read-reference r phase))
|
|
(const b object (plus a phase))
|
|
(const c object (add b 1.0 phase))
|
|
(write-reference r c phase)
|
|
(return b)))
|
|
(production :full-postfix-expression (:postfix-expression :no-line-break --) full-postfix-expression-decrement
|
|
((validate cxt env) :forward)
|
|
((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"))
|
|
(const r obj-or-ref ((eval :postfix-expression) env phase))
|
|
(const a object (read-reference r phase))
|
|
(const b object (plus a phase))
|
|
(const c object (subtract b 1.0 phase))
|
|
(write-reference r c phase)
|
|
(return b))))
|
|
|
|
(rule :full-new-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :full-new-expression (new :full-new-subexpression :arguments) full-new-expression-new
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const f object (read-reference ((eval :full-new-subexpression) env phase) phase))
|
|
(const args (vector object) ((eval :arguments) env phase))
|
|
(return (construct f args phase)))))
|
|
|
|
(rule :full-new-subexpression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :full-new-subexpression (:primary-expression) full-new-subexpression-primary-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :primary-expression) env phase))))
|
|
(production :full-new-subexpression (:qualified-identifier) full-new-subexpression-qualified-identifier
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const m multiname ((eval :qualified-identifier) env phase))
|
|
(return (new lexical-reference env m (strict :qualified-identifier)))))
|
|
(production :full-new-subexpression (:full-new-expression) full-new-subexpression-full-new-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :full-new-expression) env phase))))
|
|
(production :full-new-subexpression (:full-new-subexpression :property-operator) full-new-subexpression-property-operator
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :full-new-subexpression) env phase) phase))
|
|
(return ((eval :property-operator) env a phase))))
|
|
(production :full-new-subexpression (:super-expression :property-operator) full-new-subexpression-super-property-operator
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a obj-optional-limit ((eval :super-expression) env phase))
|
|
(return ((eval :property-operator) env a phase)))))
|
|
|
|
(rule :short-new-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :short-new-expression (new :short-new-subexpression) short-new-expression-new
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const f object (read-reference ((eval :short-new-subexpression) env phase) phase))
|
|
(return (construct f (vector-of object) phase)))))
|
|
|
|
(rule :short-new-subexpression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :short-new-subexpression (:full-new-subexpression) short-new-subexpression-new-full
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) :forward-result))
|
|
(production :short-new-subexpression (:short-new-expression) short-new-subexpression-new-short
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) :forward-result)))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Property Operators")
|
|
(rule :property-operator ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment obj-optional-limit phase) obj-or-ref)))
|
|
(production :property-operator (\. :qualified-identifier) property-operator-qualified-identifier
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env base phase)
|
|
(const m multiname ((eval :qualified-identifier) env phase))
|
|
(case base
|
|
(:narrow object (return (new dot-reference base (object-type base) m)))
|
|
(:narrow limited-instance (return (new dot-reference (& instance base) (& limit base) m))))))
|
|
(production :property-operator (:brackets) property-operator-brackets
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env base phase)
|
|
(const args (vector object) ((eval :brackets) env phase))
|
|
(case base
|
|
(:narrow object (return (new bracket-reference base (object-type base) args)))
|
|
(:narrow limited-instance (return (new bracket-reference (& instance base) (& limit base) args)))))))
|
|
|
|
(rule :brackets ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) (vector object))))
|
|
(production :brackets ([ ]) brackets-none
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return (vector-of object))))
|
|
(production :brackets ([ (:list-expression allow-in) ]) brackets-some
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval-as-list :list-expression) env phase))))
|
|
(production :brackets ([ :expressions-with-rest ]) brackets-rest
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :expressions-with-rest) env phase)))))
|
|
|
|
(rule :arguments ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) (vector object))))
|
|
(production :arguments (\( \)) arguments-none
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return (vector-of object))))
|
|
(production :arguments (:paren-list-expression) arguments-some
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval-as-list :paren-list-expression) env phase))))
|
|
(production :arguments (\( :expressions-with-rest \)) arguments-rest
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :expressions-with-rest) env phase)))))
|
|
|
|
(rule :expressions-with-rest ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) (vector object))))
|
|
(production :expressions-with-rest (:rest-expression) expressions-with-rest-one
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :rest-expression) env phase))))
|
|
(production :expressions-with-rest ((:list-expression allow-in) \, :rest-expression) expressions-with-rest-more
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const args1 (vector object) ((eval-as-list :list-expression) env phase))
|
|
(const args2 (vector object) ((eval :rest-expression) env phase))
|
|
(return (append args1 args2)))))
|
|
|
|
(rule :rest-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) (vector object))))
|
|
(production :rest-expression (\.\.\. (:assignment-expression allow-in)) rest-expression-one
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :assignment-expression) env phase) phase))
|
|
(const length integer (read-length a phase))
|
|
(var i integer 0)
|
|
(var args (vector object) (vector-of object))
|
|
(while (/= i length)
|
|
(const arg object-opt (index-read a i phase))
|
|
(rwhen (in arg (tag none) :narrow-false)
|
|
(/* "An implementation may, at its discretion, either " (:keyword throw) " a " (:global -reference-error)
|
|
" or treat the hole as a missing argument, substituting the called function" :apostrophe "s default parameter value if there is one, "
|
|
(:tag undefined) " if the called function is unchecked, or " (:keyword throw) "ing an " (:global -argument-error) " exception otherwise. "
|
|
"An implementation must not replace such a hole with " (:tag undefined) " except when the called function is unchecked or happens to "
|
|
"have " (:tag undefined) " as its default parameter value.")
|
|
(throw-error -reference-error))
|
|
(<- args (append args (vector arg)))
|
|
(<- i (+ i 1)))
|
|
(return args))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Unary Operators")
|
|
(rule :unary-expression ((strict (writable-cell boolean))
|
|
(validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :unary-expression (:postfix-expression) unary-expression-postfix
|
|
((validate cxt env) ((validate :postfix-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :postfix-expression) env phase))))
|
|
(production :unary-expression (delete :postfix-expression) unary-expression-delete
|
|
((validate cxt env)
|
|
((validate :postfix-expression) cxt env)
|
|
(action<- (strict :unary-expression 0) (& strict cxt)))
|
|
((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"))
|
|
(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
|
|
((validate cxt env) ((validate :unary-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(exec (read-reference ((eval :unary-expression) env phase) phase))
|
|
(return undefined)))
|
|
(production :unary-expression (typeof :unary-expression) unary-expression-typeof
|
|
((validate cxt env) ((validate :unary-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :unary-expression) env phase) phase))
|
|
(const c class (object-type a))
|
|
(return (& typeof-string c))))
|
|
(production :unary-expression (++ :postfix-expression) unary-expression-increment
|
|
((validate cxt env) ((validate :postfix-expression) cxt env))
|
|
((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"))
|
|
(const r obj-or-ref ((eval :postfix-expression) env phase))
|
|
(const a object (read-reference r phase))
|
|
(const b object (plus a phase))
|
|
(const c object (add b 1.0 phase))
|
|
(write-reference r c phase)
|
|
(return c)))
|
|
(production :unary-expression (-- :postfix-expression) unary-expression-decrement
|
|
((validate cxt env) ((validate :postfix-expression) cxt env))
|
|
((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"))
|
|
(const r obj-or-ref ((eval :postfix-expression) env phase))
|
|
(const a object (read-reference r phase))
|
|
(const b object (plus a phase))
|
|
(const c object (subtract b 1.0 phase))
|
|
(write-reference r c phase)
|
|
(return c)))
|
|
(production :unary-expression (+ :unary-expression) unary-expression-plus
|
|
((validate cxt env) ((validate :unary-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :unary-expression) env phase) phase))
|
|
(return (plus a phase))))
|
|
(production :unary-expression (- :unary-expression) unary-expression-minus
|
|
((validate cxt env) ((validate :unary-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :unary-expression) env phase) phase))
|
|
(return (minus a phase))))
|
|
(production :unary-expression (- $negated-min-long) unary-expression-min-long
|
|
((validate (cxt :unused) (env :unused)))
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused))
|
|
(return (new long (neg (expt 2 63))))))
|
|
(production :unary-expression (~ :unary-expression) unary-expression-bitwise-not
|
|
((validate cxt env) ((validate :unary-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :unary-expression) env phase) phase))
|
|
(return (bit-not a phase))))
|
|
(production :unary-expression (! :unary-expression) unary-expression-logical-not
|
|
((validate cxt env) ((validate :unary-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :unary-expression) env phase) phase))
|
|
(return (logical-not a phase)))))
|
|
(%print-actions ("Validation" strict validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%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 (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 (object-to-general-number a phase))
|
|
(return (general-number-negate x)))
|
|
|
|
(define (general-number-negate (x general-number)) general-number
|
|
(case x
|
|
(:narrow long (return (integer-to-long (neg (& value x)))))
|
|
(:narrow u-long (return (integer-to-u-long (neg (& value x)))))
|
|
(:narrow float32 (return (float32-negate x)))
|
|
(:narrow float64 (return (float64-negate x)))))
|
|
|
|
(define (bit-not (a object) (phase phase)) object
|
|
(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))
|
|
(return (new long (bitwise-xor i -1))))
|
|
(:narrow u-long
|
|
(const i (integer-range 0 (- (expt 2 64) 1)) (& value x))
|
|
(return (new u-long (bitwise-xor i (hex #xFFFFFFFFFFFFFFFF)))))
|
|
(:narrow (union float32 float64)
|
|
(const i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x)))
|
|
(return (real-to-float64 (bitwise-xor i -1))))))
|
|
|
|
(%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 :unused)) object
|
|
(return (not (object-to-boolean a))))
|
|
|
|
|
|
(%heading 2 "Multiplicative Operators")
|
|
(rule :multiplicative-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :multiplicative-expression (:unary-expression) multiplicative-expression-unary
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :unary-expression) env phase))))
|
|
(production :multiplicative-expression (:multiplicative-expression * :unary-expression) multiplicative-expression-multiply
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :multiplicative-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :unary-expression) env phase) phase))
|
|
(return (multiply a b phase))))
|
|
(production :multiplicative-expression (:multiplicative-expression / :unary-expression) multiplicative-expression-divide
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :multiplicative-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :unary-expression) env phase) phase))
|
|
(return (divide a b phase))))
|
|
(production :multiplicative-expression (:multiplicative-expression % :unary-expression) multiplicative-expression-remainder
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :multiplicative-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :unary-expression) env phase) phase))
|
|
(return (remainder a b phase)))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
(define (multiply (a object) (b object) (phase phase)) object
|
|
(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))
|
|
(rwhen (and (not-in i (tag none) :narrow-true) (not-in j (tag none) :narrow-true))
|
|
(const k integer (* i j))
|
|
(if (or (in x u-long) (in y u-long))
|
|
(return (integer-to-u-long k))
|
|
(return (integer-to-long k)))))
|
|
(return (float64-multiply (to-float64 x) (to-float64 y))))
|
|
|
|
(define (divide (a object) (b object) (phase phase)) object
|
|
(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))
|
|
(rwhen (and (not-in i (tag none) :narrow-true) (not-in j (tag none) :narrow-true) (/= j 0))
|
|
(const q rational (rat/ i j))
|
|
(if (or (in x u-long) (in y u-long))
|
|
(return (rational-to-u-long q))
|
|
(return (rational-to-long q)))))
|
|
(return (float64-divide (to-float64 x) (to-float64 y))))
|
|
|
|
(define (remainder (a object) (b object) (phase phase)) object
|
|
(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))
|
|
(rwhen (and (not-in i (tag none) :narrow-true) (not-in j (tag none) :narrow-true) (/= j 0))
|
|
(const q rational (rat/ i j))
|
|
(const k integer (if (>= q 0 rational) (floor q) (ceiling q)))
|
|
(const r integer (- i (* j k)))
|
|
(if (or (in x u-long) (in y u-long))
|
|
(return (integer-to-u-long r))
|
|
(return (integer-to-long r)))))
|
|
(return (float64-remainder (to-float64 x) (to-float64 y))))
|
|
|
|
|
|
(%heading 2 "Additive Operators")
|
|
(rule :additive-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :additive-expression (:multiplicative-expression) additive-expression-multiplicative
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :multiplicative-expression) env phase))))
|
|
(production :additive-expression (:additive-expression + :multiplicative-expression) additive-expression-add
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :additive-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :multiplicative-expression) env phase) phase))
|
|
(return (add a b phase))))
|
|
(production :additive-expression (:additive-expression - :multiplicative-expression) additive-expression-subtract
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :additive-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :multiplicative-expression) env phase) phase))
|
|
(return (subtract a b phase)))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
(define (add (a object) (b object) (phase phase)) object
|
|
(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 (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))
|
|
(rwhen (and (not-in i (tag none) :narrow-true) (not-in j (tag none) :narrow-true))
|
|
(const k integer (+ i j))
|
|
(if (or (in x u-long) (in y u-long))
|
|
(return (integer-to-u-long k))
|
|
(return (integer-to-long k)))))
|
|
(return (float64-add (to-float64 x) (to-float64 y))))
|
|
|
|
(define (subtract (a object) (b object) (phase phase)) object
|
|
(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))
|
|
(rwhen (and (not-in i (tag none) :narrow-true) (not-in j (tag none) :narrow-true))
|
|
(const k integer (- i j))
|
|
(if (or (in x u-long) (in y u-long))
|
|
(return (integer-to-u-long k))
|
|
(return (integer-to-long k)))))
|
|
(return (float64-subtract (to-float64 x) (to-float64 y))))
|
|
|
|
|
|
(%heading 2 "Bitwise Shift Operators")
|
|
(rule :shift-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :shift-expression (:additive-expression) shift-expression-additive
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :additive-expression) env phase))))
|
|
(production :shift-expression (:shift-expression << :additive-expression) shift-expression-left
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :shift-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :additive-expression) env phase) phase))
|
|
(return (shift-left a b phase))))
|
|
(production :shift-expression (:shift-expression >> :additive-expression) shift-expression-right-signed
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :shift-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :additive-expression) env phase) phase))
|
|
(return (shift-right a b phase))))
|
|
(production :shift-expression (:shift-expression >>> :additive-expression) shift-expression-right-unsigned
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :shift-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :additive-expression) env phase) phase))
|
|
(return (shift-right-unsigned a b phase)))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
(define (shift-left (a object) (b object) (phase phase)) object
|
|
(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)
|
|
(<- count (bitwise-and count (hex #x1F)))
|
|
(const i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (bitwise-shift (truncate-to-integer x) count)))
|
|
(return (real-to-float64 i)))
|
|
(:narrow long
|
|
(<- count (bitwise-and count (hex #x3F)))
|
|
(const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (bitwise-shift (& value x) count)))
|
|
(return (new long i)))
|
|
(:narrow u-long
|
|
(<- count (bitwise-and count (hex #x3F)))
|
|
(const i (integer-range 0 (- (expt 2 64) 1)) (unsigned-wrap64 (bitwise-shift (& value x) count)))
|
|
(return (new u-long i)))))
|
|
|
|
(define (shift-right (a object) (b object) (phase phase)) object
|
|
(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)))
|
|
(<- count (bitwise-and count (hex #x1F)))
|
|
(<- i (bitwise-shift i (neg count)))
|
|
(return (real-to-float64 i)))
|
|
(:narrow long
|
|
(<- count (bitwise-and count (hex #x3F)))
|
|
(const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (bitwise-shift (& value x) (neg count)))
|
|
(return (new long i)))
|
|
(:narrow u-long
|
|
(<- count (bitwise-and count (hex #x3F)))
|
|
(const i (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (bitwise-shift (signed-wrap64 (& value x)) (neg count)))
|
|
(return (new u-long (unsigned-wrap64 i))))))
|
|
|
|
(define (shift-right-unsigned (a object) (b object) (phase phase)) object
|
|
(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)))
|
|
(<- count (bitwise-and count (hex #x1F)))
|
|
(<- i (bitwise-shift i (neg count)))
|
|
(return (real-to-float64 i)))
|
|
(:narrow long
|
|
(<- count (bitwise-and count (hex #x3F)))
|
|
(const i (integer-range 0 (- (expt 2 64) 1)) (bitwise-shift (unsigned-wrap64 (& value x)) (neg count)))
|
|
(return (new long (signed-wrap64 i))))
|
|
(:narrow u-long
|
|
(<- count (bitwise-and count (hex #x3F)))
|
|
(const i (integer-range 0 (- (expt 2 64) 1)) (bitwise-shift (& value x) (neg count)))
|
|
(return (new u-long i)))))
|
|
|
|
|
|
(%heading 2 "Relational Operators")
|
|
(rule (:relational-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:relational-expression :beta) (:shift-expression) relational-expression-shift
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :shift-expression) env phase))))
|
|
(production (:relational-expression :beta) ((:relational-expression :beta) < :shift-expression) relational-expression-less
|
|
((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))
|
|
(return (is-less a b phase))))
|
|
(production (:relational-expression :beta) ((:relational-expression :beta) > :shift-expression) relational-expression-greater
|
|
((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))
|
|
(return (is-less b a phase))))
|
|
(production (:relational-expression :beta) ((:relational-expression :beta) <= :shift-expression) relational-expression-less-or-equal
|
|
((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))
|
|
(return (is-less-or-equal a b phase))))
|
|
(production (:relational-expression :beta) ((:relational-expression :beta) >= :shift-expression) relational-expression-greater-or-equal
|
|
((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))
|
|
(return (is-less-or-equal b a phase))))
|
|
(production (:relational-expression :beta) ((:relational-expression :beta) is :shift-expression) relational-expression-is
|
|
((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 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)
|
|
((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 c class (object-to-class b))
|
|
(return (coerce-or-null a c))))
|
|
(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))
|
|
(return (has-property b a false phase))))
|
|
(production (:relational-expression :beta) ((:relational-expression :beta) instanceof :shift-expression) relational-expression-instanceof
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(var a object (read-reference ((eval :relational-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :shift-expression) env phase) phase))
|
|
(cond
|
|
((in b class :narrow-true)
|
|
(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 (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 (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) (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 (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) (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")
|
|
(rule (:equality-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:equality-expression :beta) ((:relational-expression :beta)) equality-expression-relational
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :relational-expression) env phase))))
|
|
(production (:equality-expression :beta) ((:equality-expression :beta) == (:relational-expression :beta)) equality-expression-equal
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :equality-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :relational-expression) env phase) phase))
|
|
(return (is-equal a b phase))))
|
|
(production (:equality-expression :beta) ((:equality-expression :beta) != (:relational-expression :beta)) equality-expression-not-equal
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :equality-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :relational-expression) env phase) phase))
|
|
(return (not (is-equal a b phase)))))
|
|
(production (:equality-expression :beta) ((:equality-expression :beta) === (:relational-expression :beta)) equality-expression-strict-equal
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :equality-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :relational-expression) env phase) phase))
|
|
(return (is-strictly-equal a b phase))))
|
|
(production (:equality-expression :beta) ((:equality-expression :beta) !== (:relational-expression :beta)) equality-expression-strict-not-equal
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :equality-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :relational-expression) env phase) phase))
|
|
(return (not (is-strictly-equal a b phase))))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
(define (is-equal (a object) (b object) (phase phase)) boolean
|
|
(case a
|
|
(:select (union undefined null)
|
|
(return (in b (union undefined null))))
|
|
(:narrow boolean
|
|
(if (in b boolean :narrow-true)
|
|
(return (= a b boolean))
|
|
(return (is-equal (object-to-general-number a phase) b phase))))
|
|
(:narrow general-number
|
|
(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 (object-to-general-number bp phase)) equal order)))))
|
|
(:narrow (union char16 string)
|
|
(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 (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 (object-to-primitive a none phase))
|
|
(return (is-equal ap b phase)))))))
|
|
|
|
(define (is-strictly-equal (a object) (b object) (phase phase :unused)) boolean
|
|
(cond
|
|
((and (in a general-number :narrow-true) (in b general-number :narrow-true))
|
|
(return (= (general-number-compare a b) equal order)))
|
|
(nil
|
|
(return (= a b object)))))
|
|
|
|
|
|
(%heading 2 "Binary Bitwise Operators")
|
|
(rule (:bitwise-and-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:bitwise-and-expression :beta) ((:equality-expression :beta)) bitwise-and-expression-equality
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :equality-expression) env phase))))
|
|
(production (:bitwise-and-expression :beta) ((:bitwise-and-expression :beta) & (:equality-expression :beta)) bitwise-and-expression-and
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :bitwise-and-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :equality-expression) env phase) phase))
|
|
(return (bit-and a b phase)))))
|
|
|
|
(rule (:bitwise-xor-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:bitwise-xor-expression :beta) ((:bitwise-and-expression :beta)) bitwise-xor-expression-bitwise-and
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :bitwise-and-expression) env phase))))
|
|
(production (:bitwise-xor-expression :beta) ((:bitwise-xor-expression :beta) ^ (:bitwise-and-expression :beta)) bitwise-xor-expression-xor
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :bitwise-xor-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :bitwise-and-expression) env phase) phase))
|
|
(return (bit-xor a b phase)))))
|
|
|
|
(rule (:bitwise-or-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:bitwise-or-expression :beta) ((:bitwise-xor-expression :beta)) bitwise-or-expression-bitwise-xor
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :bitwise-xor-expression) env phase))))
|
|
(production (:bitwise-or-expression :beta) ((:bitwise-or-expression :beta) \| (:bitwise-xor-expression :beta)) bitwise-or-expression-or
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :bitwise-or-expression) env phase) phase))
|
|
(const b object (read-reference ((eval :bitwise-xor-expression) env phase) phase))
|
|
(return (bit-or a b phase)))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
(define (bit-and (a object) (b object) (phase phase)) general-number
|
|
(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)))
|
|
(const j (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer y)))
|
|
(const k (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (bitwise-and i j))
|
|
(if (or (in x u-long) (in y u-long))
|
|
(return (new u-long (unsigned-wrap64 k)))
|
|
(return (new long k))))
|
|
(nil
|
|
(const i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x)))
|
|
(const j (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer y)))
|
|
(return (real-to-float64 (bitwise-and i j))))))
|
|
|
|
(define (bit-xor (a object) (b object) (phase phase)) general-number
|
|
(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)))
|
|
(const j (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer y)))
|
|
(const k (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (bitwise-xor i j))
|
|
(if (or (in x u-long) (in y u-long))
|
|
(return (new u-long (unsigned-wrap64 k)))
|
|
(return (new long k))))
|
|
(nil
|
|
(const i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x)))
|
|
(const j (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer y)))
|
|
(return (real-to-float64 (bitwise-xor i j))))))
|
|
|
|
(define (bit-or (a object) (b object) (phase phase)) general-number
|
|
(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)))
|
|
(const j (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (signed-wrap64 (truncate-to-integer y)))
|
|
(const k (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)) (bitwise-or i j))
|
|
(if (or (in x u-long) (in y u-long))
|
|
(return (new u-long (unsigned-wrap64 k)))
|
|
(return (new long k))))
|
|
(nil
|
|
(const i (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer x)))
|
|
(const j (integer-range (neg (expt 2 31)) (- (expt 2 31) 1)) (signed-wrap32 (truncate-to-integer y)))
|
|
(return (real-to-float64 (bitwise-or i j))))))
|
|
|
|
|
|
(%heading 2 "Binary Logical Operators")
|
|
(rule (:logical-and-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:logical-and-expression :beta) ((:bitwise-or-expression :beta)) logical-and-expression-bitwise-or
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :bitwise-or-expression) env phase))))
|
|
(production (:logical-and-expression :beta) ((:logical-and-expression :beta) && (:bitwise-or-expression :beta)) logical-and-expression-and
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :logical-and-expression) env phase) phase))
|
|
(if (object-to-boolean a)
|
|
(return (read-reference ((eval :bitwise-or-expression) env phase) phase))
|
|
(return a)))))
|
|
|
|
(rule (:logical-xor-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:logical-xor-expression :beta) ((:logical-and-expression :beta)) logical-xor-expression-logical-and
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :logical-and-expression) env phase))))
|
|
(production (:logical-xor-expression :beta) ((:logical-xor-expression :beta) ^^ (:logical-and-expression :beta)) logical-xor-expression-xor
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((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 (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))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:logical-or-expression :beta) ((:logical-xor-expression :beta)) logical-or-expression-logical-xor
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :logical-xor-expression) env phase))))
|
|
(production (:logical-or-expression :beta) ((:logical-or-expression :beta) \|\| (:logical-xor-expression :beta)) logical-or-expression-or
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :logical-or-expression) env phase) 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))
|
|
|
|
|
|
(%heading 2 "Conditional Operator")
|
|
(rule (:conditional-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:conditional-expression :beta) ((:logical-or-expression :beta)) conditional-expression-logical-or
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :logical-or-expression) env phase))))
|
|
(production (:conditional-expression :beta) ((:logical-or-expression :beta) ? (:assignment-expression :beta) \: (:assignment-expression :beta)) conditional-expression-conditional
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :logical-or-expression) env phase) 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))))))
|
|
|
|
(rule (:non-assignment-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:non-assignment-expression :beta) ((:logical-or-expression :beta)) non-assignment-expression-logical-or
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :logical-or-expression) env phase))))
|
|
(production (:non-assignment-expression :beta) ((:logical-or-expression :beta) ? (:non-assignment-expression :beta) \: (:non-assignment-expression :beta)) non-assignment-expression-conditional
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :logical-or-expression) env phase) 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))
|
|
|
|
|
|
(%heading 2 "Assignment Operators")
|
|
(rule (:assignment-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production (:assignment-expression :beta) ((:conditional-expression :beta)) assignment-expression-conditional
|
|
((validate cxt env) ((validate :conditional-expression) cxt env))
|
|
((setup) ((setup :conditional-expression)))
|
|
((eval env phase) (return ((eval :conditional-expression) env phase))))
|
|
(production (:assignment-expression :beta) (:postfix-expression = (:assignment-expression :beta)) assignment-expression-assignment
|
|
((validate cxt env)
|
|
((validate :postfix-expression) cxt env)
|
|
((validate :assignment-expression) cxt env))
|
|
((setup)
|
|
((setup :postfix-expression))
|
|
((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"))
|
|
(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)
|
|
(return b)))
|
|
(production (:assignment-expression :beta) (:postfix-expression :compound-assignment (:assignment-expression :beta)) assignment-expression-compound
|
|
((validate cxt env)
|
|
((validate :postfix-expression) cxt env)
|
|
((validate :assignment-expression) cxt env))
|
|
((setup)
|
|
((setup :postfix-expression))
|
|
((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"))
|
|
(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))
|
|
(const result object ((op :compound-assignment) o-left o-right phase))
|
|
(write-reference r-left result phase)
|
|
(return result)))
|
|
(production (:assignment-expression :beta) (:postfix-expression :logical-assignment (:assignment-expression :beta)) assignment-expression-logical-compound
|
|
((validate cxt env)
|
|
((validate :postfix-expression) cxt env)
|
|
((validate :assignment-expression) cxt env))
|
|
((setup)
|
|
((setup :postfix-expression))
|
|
((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"))
|
|
(const r-left obj-or-ref ((eval :postfix-expression) env phase))
|
|
(const o-left object (read-reference r-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 (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)
|
|
(<- result (read-reference ((eval :assignment-expression) env phase) phase)))))
|
|
(write-reference r-left result phase)
|
|
(return result))))
|
|
|
|
(rule :compound-assignment ((op (-> (object object phase) object)))
|
|
(production :compound-assignment (*=) compound-assignment-multiply (op multiply))
|
|
(production :compound-assignment (/=) compound-assignment-divide (op divide))
|
|
(production :compound-assignment (%=) compound-assignment-remainder (op remainder))
|
|
(production :compound-assignment (+=) compound-assignment-add (op add))
|
|
(production :compound-assignment (-=) compound-assignment-subtract (op subtract))
|
|
(production :compound-assignment (<<=) compound-assignment-shift-left (op shift-left))
|
|
(production :compound-assignment (>>=) compound-assignment-shift-right (op shift-right))
|
|
(production :compound-assignment (>>>=) compound-assignment-shift-right-unsigned (op shift-right-unsigned))
|
|
(production :compound-assignment (&=) compound-assignment-bit-and (op bit-and))
|
|
(production :compound-assignment (^=) compound-assignment-bit-xor (op bit-xor))
|
|
(production :compound-assignment (\|=) compound-assignment-bit-or (op bit-or)))
|
|
|
|
(rule :logical-assignment ((operator (tag and-eq xor-eq or-eq)))
|
|
(production :logical-assignment (&&=) logical-assignment-logical-and (operator and-eq))
|
|
(production :logical-assignment (^^=) logical-assignment-logical-xor (operator xor-eq))
|
|
(production :logical-assignment (\|\|=) logical-assignment-logical-or (operator or-eq)))
|
|
|
|
(deftag and-eq)
|
|
(deftag xor-eq)
|
|
(deftag or-eq)
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" op operator eval))
|
|
|
|
|
|
(%heading 2 "Comma Expressions")
|
|
(rule (:list-expression :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref))
|
|
(eval-as-list (-> (environment phase) (vector object))))
|
|
(production (:list-expression :beta) ((:assignment-expression :beta)) list-expression-assignment
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :assignment-expression) env phase)))
|
|
((eval-as-list env phase)
|
|
(const elt object (read-reference ((eval :assignment-expression) env phase) phase))
|
|
(return (vector elt))))
|
|
(production (:list-expression :beta) ((:list-expression :beta) \, (:assignment-expression :beta)) list-expression-comma
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(exec (read-reference ((eval :list-expression) env phase) phase))
|
|
(return (read-reference ((eval :assignment-expression) env phase) phase)))
|
|
((eval-as-list env phase)
|
|
(const elts (vector object) ((eval-as-list :list-expression) env phase))
|
|
(const elt object (read-reference ((eval :assignment-expression) env phase) phase))
|
|
(return (append elts (vector elt))))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Type Expressions")
|
|
(rule (:type-expression :beta) ((validate (-> (context environment) void))
|
|
(setup-and-eval (-> (environment) class)))
|
|
(production (:type-expression :beta) ((:non-assignment-expression :beta)) type-expression-non-assignment-expression
|
|
((validate cxt env) :forward)
|
|
((setup-and-eval env)
|
|
((setup :non-assignment-expression))
|
|
(const o object (read-reference ((eval :non-assignment-expression) env compile) compile))
|
|
(return (object-to-class o)))))
|
|
(%print-actions ("Validation" validate) ("Setup and Evaluation" setup-and-eval))
|
|
|
|
|
|
(%heading 1 "Statements")
|
|
|
|
(grammar-argument :omega
|
|
abbrev ;optional semicolon when followed by a '}', 'else', or 'while' in a do-while
|
|
no-short-if ;optional semicolon, but statement must not end with an if without an else
|
|
full) ;semicolon required at the end
|
|
(grammar-argument :omega_2 abbrev full)
|
|
|
|
(rule (:statement :omega) ((validate (-> (context environment (list-set label) jump-targets boolean) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production (:statement :omega) (:expression-statement (:semicolon :omega)) statement-expression-statement
|
|
((validate cxt env (sl :unused) (jt :unused) (preinst :unused)) ((validate :expression-statement) cxt env))
|
|
((setup) :forward)
|
|
((eval env (d :unused)) (return ((eval :expression-statement) env))))
|
|
(production (:statement :omega) (:super-statement (:semicolon :omega)) statement-super-statement
|
|
((validate cxt env (sl :unused) (jt :unused) (preinst :unused)) ((validate :super-statement) cxt env))
|
|
((setup) :forward)
|
|
((eval env (d :unused)) (return ((eval :super-statement) env))))
|
|
(production (:statement :omega) (:block) statement-block
|
|
((validate cxt env (sl :unused) jt preinst) ((validate :block) cxt env jt preinst))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :block) env d))))
|
|
(production (:statement :omega) ((:labeled-statement :omega)) statement-labeled-statement
|
|
((validate cxt env sl jt (preinst :unused)) ((validate :labeled-statement) cxt env sl jt))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :labeled-statement) env d))))
|
|
(production (:statement :omega) ((:if-statement :omega)) statement-if-statement
|
|
((validate cxt env (sl :unused) jt (preinst :unused)) ((validate :if-statement) cxt env jt))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :if-statement) env d))))
|
|
(production (:statement :omega) (:switch-statement) statement-switch-statement
|
|
((validate cxt env (sl :unused) jt (preinst :unused)) ((validate :switch-statement) cxt env jt))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :switch-statement) env d))))
|
|
(production (:statement :omega) (:do-statement (:semicolon :omega)) statement-do-statement
|
|
((validate cxt env sl jt (preinst :unused)) ((validate :do-statement) cxt env sl jt))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :do-statement) env d))))
|
|
(production (:statement :omega) ((:while-statement :omega)) statement-while-statement
|
|
((validate cxt env sl jt (preinst :unused)) ((validate :while-statement) cxt env sl jt))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :while-statement) env d))))
|
|
(production (:statement :omega) ((:for-statement :omega)) statement-for-statement
|
|
((validate cxt env sl jt (preinst :unused)) ((validate :for-statement) cxt env sl jt))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :for-statement) env d))))
|
|
(production (:statement :omega) ((:with-statement :omega)) statement-with-statement
|
|
((validate cxt env (sl :unused) jt (preinst :unused)) ((validate :with-statement) cxt env jt))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :with-statement) env d))))
|
|
(production (:statement :omega) (:continue-statement (:semicolon :omega)) statement-continue-statement
|
|
((validate (cxt :unused) (env :unused) (sl :unused) jt (preinst :unused)) ((validate :continue-statement) jt))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :continue-statement) env d))))
|
|
(production (:statement :omega) (:break-statement (:semicolon :omega)) statement-break-statement
|
|
((validate (cxt :unused) (env :unused) (sl :unused) jt (preinst :unused)) ((validate :break-statement) jt))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :break-statement) env d))))
|
|
(production (:statement :omega) (:return-statement (:semicolon :omega)) statement-return-statement
|
|
((validate cxt env (sl :unused) (jt :unused) (preinst :unused)) ((validate :return-statement) cxt env))
|
|
((setup) :forward)
|
|
((eval env (d :unused)) (return ((eval :return-statement) env))))
|
|
(production (:statement :omega) (:throw-statement (:semicolon :omega)) statement-throw-statement
|
|
((validate cxt env (sl :unused) (jt :unused) (preinst :unused)) ((validate :throw-statement) cxt env))
|
|
((setup) :forward)
|
|
((eval env (d :unused)) (return ((eval :throw-statement) env))))
|
|
(production (:statement :omega) (:try-statement) statement-try-statement
|
|
((validate cxt env (sl :unused) jt (preinst :unused)) ((validate :try-statement) cxt env jt))
|
|
((setup) :forward)
|
|
((eval env d) (return ((eval :try-statement) env d)))))
|
|
|
|
|
|
(rule (:substatement :omega) ((enabled (writable-cell boolean))
|
|
(validate (-> (context environment (list-set label) jump-targets) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production (:substatement :omega) (:empty-statement) substatement-empty-statement
|
|
((validate (cxt :unused) (env :unused) (sl :unused) (jt :unused)))
|
|
((setup))
|
|
((eval (env :unused) d) (return d)))
|
|
(production (:substatement :omega) ((:statement :omega)) substatement-statement
|
|
((validate cxt env sl jt) ((validate :statement) cxt env sl jt false))
|
|
((setup) ((setup :statement)))
|
|
((eval env d) (return ((eval :statement) env d))))
|
|
(production (:substatement :omega) (:simple-variable-definition (:semicolon :omega)) substatement-simple-variable-definition
|
|
((validate cxt env (sl :unused) (jt :unused)) ((validate :simple-variable-definition) cxt env))
|
|
((setup) ((setup :simple-variable-definition)))
|
|
((eval env d) (return ((eval :simple-variable-definition) env d))))
|
|
(production (:substatement :omega) (:attributes :no-line-break { :substatements }) substatement-annotated-group
|
|
((validate cxt env (sl :unused) jt)
|
|
((validate :attributes) cxt env)
|
|
((setup :attributes))
|
|
(const attr attribute ((eval :attributes) env compile))
|
|
(rwhen (not-in attr boolean :narrow-false)
|
|
(throw-error -type-error
|
|
"attributes other than " (:character-literal "true") " and " (:character-literal "false")
|
|
" may be used in a statement but not a substatement"))
|
|
(action<- (enabled :substatement 0) attr)
|
|
(when attr
|
|
((validate :substatements) cxt env jt)))
|
|
((setup)
|
|
(when (enabled :substatement 0)
|
|
((setup :substatements))))
|
|
((eval env d)
|
|
(if (enabled :substatement 0)
|
|
(return ((eval :substatements) env d))
|
|
(return d)))))
|
|
|
|
|
|
(rule :substatements ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :substatements () substatements-none
|
|
((validate (cxt :unused) (env :unused) (jt :unused)))
|
|
((setup) :forward)
|
|
((eval (env :unused) d) (return d)))
|
|
(production :substatements (:substatements-prefix (:substatement abbrev)) substatements-more
|
|
((validate cxt env jt)
|
|
((validate :substatements-prefix) cxt env jt)
|
|
((validate :substatement) cxt env (list-set-of label) jt))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(const o object ((eval :substatements-prefix) env d))
|
|
(return ((eval :substatement) env o)))))
|
|
|
|
(rule :substatements-prefix ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :substatements-prefix () substatements-prefix-none
|
|
((validate (cxt :unused) (env :unused) (jt :unused)))
|
|
((setup) :forward)
|
|
((eval (env :unused) d) (return d)))
|
|
(production :substatements-prefix (:substatements-prefix (:substatement full)) substatements-prefix-more
|
|
((validate cxt env jt)
|
|
((validate :substatements-prefix) cxt env jt)
|
|
((validate :substatement) cxt env (list-set-of label) jt))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(const o object ((eval :substatements-prefix) env d))
|
|
(return ((eval :substatement) env o)))))
|
|
|
|
|
|
(rule (:semicolon :omega) ((setup (-> () void)))
|
|
(production (:semicolon :omega) (\;) semicolon-semicolon
|
|
((setup)))
|
|
(production (:semicolon :omega) ($virtual-semicolon) semicolon-virtual-semicolon
|
|
((setup)))
|
|
(production (:semicolon abbrev) () semicolon-abbrev
|
|
((setup)))
|
|
(production (:semicolon no-short-if) () semicolon-no-short-if
|
|
((setup))))
|
|
(%print-actions ("Validation" enabled validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Empty Statement")
|
|
(production :empty-statement (\;) empty-statement-semicolon)
|
|
|
|
|
|
(%heading 2 "Expression Statement")
|
|
(rule :expression-statement ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment) object)))
|
|
(production :expression-statement ((:- function {) (:list-expression allow-in)) expression-statement-list-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env)
|
|
(return (read-reference ((eval :list-expression) env run) run)))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Super Statement")
|
|
(rule :super-statement ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment) object)))
|
|
(production :super-statement (super :arguments) super-statement-super-arguments
|
|
((validate cxt env)
|
|
(const frame parameter-frame-opt (get-enclosing-parameter-frame env))
|
|
(rwhen (or (in frame (tag none) :narrow-false) (not-in (& kind frame) (tag constructor-function)))
|
|
(throw-error -syntax-error "a " (:character-literal "super") " statement is meaningful only inside a constructor"))
|
|
((validate :arguments) cxt env)
|
|
(&= calls-superconstructor frame true))
|
|
((setup) :forward)
|
|
((eval env)
|
|
(const frame parameter-frame-opt (get-enclosing-parameter-frame env))
|
|
(assert (and (not-in frame (tag none) :narrow-true) (in (& kind frame) (tag constructor-function)))
|
|
(:action validate) " already ensured that " (:assertion) ".")
|
|
(const args (vector object) ((eval :arguments) env run))
|
|
(rwhen (in (& superconstructor-called frame) (tag true))
|
|
(throw-error -reference-error "the superconstructor cannot be called twice"))
|
|
(const c class (assert-not-in (get-enclosing-class env) (tag none)))
|
|
(const this object-opt (& this frame))
|
|
(assert (in this simple-instance :narrow-true))
|
|
(call-init this (& super c) args run)
|
|
(&= superconstructor-called frame true)
|
|
(return this))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Block Statement")
|
|
(rule :block ((compile-frame (writable-cell local-frame))
|
|
(preinstantiate (writable-cell boolean))
|
|
(validate-using-frame (-> (context environment jump-targets boolean frame) void))
|
|
(validate (-> (context environment jump-targets boolean) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment object) object))
|
|
(eval-using-frame (-> (environment frame object) object)))
|
|
(production :block ({ :directives }) block-directives
|
|
((validate-using-frame cxt env jt preinst frame)
|
|
(const local-cxt context (new context (& strict cxt) (& open-namespaces cxt)))
|
|
((validate :directives) local-cxt (cons frame env) jt preinst none))
|
|
((validate cxt env jt preinst)
|
|
(const compile-frame local-frame (new local-frame (list-set-of local-binding)))
|
|
(action<- (compile-frame :block 0) compile-frame)
|
|
(action<- (preinstantiate :block 0) preinst)
|
|
((validate-using-frame :block 0) cxt env jt preinst compile-frame))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(const compile-frame local-frame (compile-frame :block 0))
|
|
(var runtime-frame local-frame)
|
|
(if (preinstantiate :block 0)
|
|
(<- runtime-frame compile-frame)
|
|
(<- runtime-frame (instantiate-local-frame compile-frame env)))
|
|
(return ((eval :directives) (cons runtime-frame env) d)))
|
|
((eval-using-frame env frame d)
|
|
(return ((eval :directives) (cons frame env) d)))))
|
|
(%print-actions ("Validation" compile-frame preinstantiate validate validate-using-frame) ("Setup" setup) ("Evaluation" eval eval-using-frame))
|
|
|
|
|
|
(%heading 2 "Labeled Statements")
|
|
(rule (:labeled-statement :omega) ((validate (-> (context environment (list-set label) jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production (:labeled-statement :omega) (:identifier \: (:substatement :omega)) labeled-statement-label
|
|
((validate cxt env sl jt)
|
|
(const name string (name :identifier))
|
|
(rwhen (set-in name (& break-targets jt))
|
|
(throw-error -syntax-error "nesting labeled statements with the same label is not permitted"))
|
|
(const jt2 jump-targets (new jump-targets (set+ (& break-targets jt) (list-set-of label name)) (& continue-targets jt)))
|
|
((validate :substatement) cxt env (set+ sl (list-set-of label name)) jt2))
|
|
((setup) ((setup :substatement)))
|
|
((eval env d)
|
|
(catch ((return ((eval :substatement) env d)))
|
|
(x) (if (and (in x break :narrow-true) (= (& label x) (name :identifier) label))
|
|
(return (& value x))
|
|
(throw x))))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "If Statement")
|
|
(rule (:if-statement :omega) ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production (:if-statement abbrev) (if :paren-list-expression (:substatement abbrev)) if-statement-if-then-abbrev
|
|
((validate cxt env jt)
|
|
((validate :paren-list-expression) cxt env)
|
|
((validate :substatement) cxt env (list-set-of label) jt))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(const o object (read-reference ((eval :paren-list-expression) env run) 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
|
|
((validate cxt env jt)
|
|
((validate :paren-list-expression) cxt env)
|
|
((validate :substatement) cxt env (list-set-of label) jt))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(const o object (read-reference ((eval :paren-list-expression) env run) 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))
|
|
if-statement-if-then-else
|
|
((validate cxt env jt)
|
|
((validate :paren-list-expression) cxt env)
|
|
((validate :substatement 1) cxt env (list-set-of label) jt)
|
|
((validate :substatement 2) cxt env (list-set-of label) jt))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(const o object (read-reference ((eval :paren-list-expression) env run) 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))
|
|
|
|
|
|
(%heading 2 "Switch Statement")
|
|
(deftuple switch-key
|
|
(key object))
|
|
(deftype switch-guard (union switch-key (tag default) object))
|
|
|
|
(rule :switch-statement ((compile-frame (writable-cell local-frame))
|
|
(validate (-> (context environment jump-targets) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :switch-statement (switch :paren-list-expression { :case-elements }) switch-statement-cases
|
|
((validate cxt env jt)
|
|
(rwhen (> (n-defaults :case-elements) 1)
|
|
(throw-error -syntax-error "a " (:character-literal "case") " statement may have at most one default clause"))
|
|
((validate :paren-list-expression) cxt env)
|
|
(const jt2 jump-targets (new jump-targets
|
|
(set+ (& break-targets jt) (list-set-of label default))
|
|
(& continue-targets jt)))
|
|
(const compile-frame local-frame (new local-frame (list-set-of local-binding)))
|
|
(action<- (compile-frame :switch-statement 0) compile-frame)
|
|
(const local-cxt context (new context (& strict cxt) (& open-namespaces cxt)))
|
|
((validate :case-elements) local-cxt (cons compile-frame env) jt2))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(const key object (read-reference ((eval :paren-list-expression) env run) run))
|
|
(const compile-frame local-frame (compile-frame :switch-statement 0))
|
|
(const runtime-frame local-frame (instantiate-local-frame compile-frame env))
|
|
(const runtime-env environment (cons runtime-frame env))
|
|
(var result switch-guard ((eval :case-elements) runtime-env (new switch-key key) d))
|
|
(rwhen (in result object :narrow-true)
|
|
(return result))
|
|
(assert (= result (new switch-key key) switch-guard))
|
|
(<- result ((eval :case-elements) runtime-env default d))
|
|
(rwhen (in result object :narrow-true)
|
|
(return result))
|
|
(assert (= result default switch-guard))
|
|
(return d))))
|
|
|
|
(rule :case-elements ((n-defaults integer)
|
|
(validate (-> (context environment jump-targets) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment switch-guard object) switch-guard)))
|
|
(production :case-elements () case-elements-none
|
|
(n-defaults 0)
|
|
((validate cxt env jt) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) guard (d :unused)) (return guard)))
|
|
(production :case-elements (:case-label) case-elements-one
|
|
(n-defaults (n-defaults :case-label))
|
|
((validate cxt env jt) :forward)
|
|
((setup) :forward)
|
|
((eval env guard d)
|
|
(return ((eval :case-label) env guard d))))
|
|
(production :case-elements (:case-label :case-elements-prefix (:case-element abbrev)) case-elements-more
|
|
(n-defaults (+ (n-defaults :case-label) (+ (n-defaults :case-elements-prefix) (n-defaults :case-element))))
|
|
((validate cxt env jt) :forward)
|
|
((setup) :forward)
|
|
((eval env guard d)
|
|
(const guard2 switch-guard ((eval :case-label) env guard d))
|
|
(const guard3 switch-guard ((eval :case-elements-prefix) env guard2 d))
|
|
(return ((eval :case-element) env guard3 d)))))
|
|
|
|
(rule :case-elements-prefix ((n-defaults integer)
|
|
(validate (-> (context environment jump-targets) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment switch-guard object) switch-guard)))
|
|
(production :case-elements-prefix () case-elements-prefix-none
|
|
(n-defaults 0)
|
|
((validate cxt env jt) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) guard (d :unused)) (return guard)))
|
|
(production :case-elements-prefix (:case-elements-prefix (:case-element full)) case-elements-prefix-more
|
|
(n-defaults (+ (n-defaults :case-elements-prefix) (n-defaults :case-element)))
|
|
((validate cxt env jt) :forward)
|
|
((setup) :forward)
|
|
((eval env guard d)
|
|
(const guard2 switch-guard ((eval :case-elements-prefix) env guard d))
|
|
(return ((eval :case-element) env guard2 d)))))
|
|
|
|
(rule (:case-element :omega_2) ((n-defaults integer)
|
|
(validate (-> (context environment jump-targets) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment switch-guard object) switch-guard)))
|
|
(production (:case-element :omega_2) ((:directive :omega_2)) case-element-directive
|
|
(n-defaults 0)
|
|
((validate cxt env jt) ((validate :directive) cxt env jt false none))
|
|
((setup) :forward)
|
|
((eval env guard (d :unused))
|
|
(case guard
|
|
(:narrow (union switch-key (tag default)) (return guard))
|
|
(:narrow object
|
|
(return ((eval :directive) env guard))))))
|
|
(production (:case-element :omega_2) (:case-label) case-element-case-label
|
|
(n-defaults (n-defaults :case-label))
|
|
((validate cxt env jt) ((validate :case-label) cxt env jt))
|
|
((setup) :forward)
|
|
((eval env guard d)
|
|
(return ((eval :case-label) env guard d)))))
|
|
|
|
(rule :case-label ((n-defaults integer)
|
|
(validate (-> (context environment jump-targets) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment switch-guard object) switch-guard)))
|
|
(production :case-label (case (:list-expression allow-in) \:) case-label-case
|
|
(n-defaults 0)
|
|
((validate cxt env (jt :unused)) ((validate :list-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env guard d)
|
|
(case guard
|
|
(:narrow (union (tag default) object) (return guard))
|
|
(:narrow switch-key
|
|
(const label object (read-reference ((eval :list-expression) env run) run))
|
|
(if (is-strictly-equal (& key guard) label run)
|
|
(return d)
|
|
(return guard))))))
|
|
(production :case-label (default \:) case-label-default
|
|
(n-defaults 1)
|
|
((validate (cxt :unused) (env :unused) (jt :unused)))
|
|
((setup) :forward)
|
|
((eval (env :unused) guard d)
|
|
(case guard
|
|
(:narrow (union switch-key object) (return guard))
|
|
(:narrow (tag default) (return d))))))
|
|
(%print-actions ("Validation" n-defaults compile-frame validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Do-While Statement")
|
|
(rule :do-statement ((labels (writable-cell (list-set label)))
|
|
(validate (-> (context environment (list-set label) jump-targets) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :do-statement (do (:substatement abbrev) while :paren-list-expression) do-statement-do-while
|
|
((validate cxt env sl jt)
|
|
(const continue-labels (list-set label) (set+ sl (list-set-of label default)))
|
|
(action<- (labels :do-statement 0) continue-labels)
|
|
(const jt2 jump-targets (new jump-targets
|
|
(set+ (& break-targets jt) (list-set-of label default))
|
|
(set+ (& continue-targets jt) continue-labels)))
|
|
((validate :substatement) cxt env (list-set-of label) jt2)
|
|
((validate :paren-list-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(catch ((var d1 object d)
|
|
(while true
|
|
(catch ((<- d1 ((eval :substatement) env d1)))
|
|
(x) (if (and (in x continue :narrow-true) (set-in (& label x) (labels :do-statement 0)))
|
|
(<- d1 (& value x))
|
|
(throw x)))
|
|
(const o object (read-reference ((eval :paren-list-expression) env run) run))
|
|
(rwhen (not (object-to-boolean o))
|
|
(return d1))))
|
|
(x) (if (and (in x break :narrow-true) (= (& label x) default label))
|
|
(return (& value x))
|
|
(throw x))))))
|
|
(%print-actions ("Validation" labels validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "While Statement")
|
|
(rule (:while-statement :omega) ((labels (writable-cell (list-set label)))
|
|
(validate (-> (context environment (list-set label) jump-targets) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production (:while-statement :omega) (while :paren-list-expression (:substatement :omega)) while-statement-while
|
|
((validate cxt env sl jt)
|
|
(const continue-labels (list-set label) (set+ sl (list-set-of label default)))
|
|
(action<- (labels :while-statement 0) continue-labels)
|
|
(const jt2 jump-targets (new jump-targets
|
|
(set+ (& break-targets jt) (list-set-of label default))
|
|
(set+ (& continue-targets jt) continue-labels)))
|
|
((validate :paren-list-expression) cxt env)
|
|
((validate :substatement) cxt env (list-set-of label) jt2))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(catch ((var d1 object d)
|
|
(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))
|
|
(throw x))))
|
|
(return d1))
|
|
(x) (if (and (in x break :narrow-true) (= (& label x) default label))
|
|
(return (& value x))
|
|
(throw x))))))
|
|
(%print-actions ("Validation" labels validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "For Statements")
|
|
(rule (:for-statement :omega) ((labels (writable-cell (list-set label)))
|
|
(compile-local-frame (writable-cell local-frame))
|
|
(validate (-> (context environment (list-set label) jump-targets) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(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)))
|
|
(action<- (labels :for-statement 0) continue-labels)
|
|
(const jt2 jump-targets (new jump-targets
|
|
(set+ (& break-targets jt) (list-set-of label default))
|
|
(set+ (& continue-targets jt) continue-labels)))
|
|
(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-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))
|
|
((setup) :forward)
|
|
((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-initializer) runtime-env)
|
|
(var d1 object d)
|
|
(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))
|
|
(throw x)))
|
|
(exec (read-reference ((eval :optional-expression 2) runtime-env run) run)))
|
|
(return d1))
|
|
(x) (if (and (in x break :narrow-true) (= (& label x) default label))
|
|
(return (& value x))
|
|
(throw x)))))
|
|
|
|
(production (:for-statement :omega) (for \( :for-in-binding in (:list-expression allow-in) \) (:substatement :omega)) for-statement-in
|
|
((validate cxt env sl jt)
|
|
(const continue-labels (list-set label) (set+ sl (list-set-of label default)))
|
|
(action<- (labels :for-statement 0) continue-labels)
|
|
(const jt2 jump-targets (new jump-targets
|
|
(set+ (& break-targets jt) (list-set-of label default))
|
|
(set+ (& continue-targets jt) continue-labels)))
|
|
((validate :list-expression) cxt env)
|
|
(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-in-binding) cxt compile-env)
|
|
((validate :substatement) cxt compile-env (list-set-of label) jt2))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(catch ((const o object (read-reference ((eval :list-expression) env run) run))
|
|
(const c class (object-type o))
|
|
(var old-indices (list-set object) ((& enumerate c) o))
|
|
(var remaining-indices (list-set object) old-indices)
|
|
(var d1 object d)
|
|
(while (nonempty remaining-indices)
|
|
(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))
|
|
(const index object (elt-of remaining-indices))
|
|
(<- remaining-indices (set- remaining-indices (list-set index)))
|
|
((write-binding :for-in-binding) runtime-env index)
|
|
(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))
|
|
(throw x)))
|
|
(var new-indices (list-set object) ((& enumerate c) o))
|
|
(when (/= new-indices old-indices (list-set object))
|
|
(// "The implementation may, at its discretion, add none, some, or all of the objects in the set difference "
|
|
(:expr (list-set object) (set- new-indices old-indices)) " to " (:local remaining-indices) ";")
|
|
(// "The implementation may, at its discretion, remove none, some, or all of the objects in the set difference "
|
|
(:expr (list-set object) (set- old-indices new-indices)) " from " (:local remaining-indices) ";"))
|
|
(<- old-indices new-indices))
|
|
(return d1))
|
|
(x) (if (and (in x break :narrow-true) (= (& label x) default label))
|
|
(return (& value x))
|
|
(throw x))))))
|
|
|
|
|
|
(rule :for-initializer ((enabled (writable-cell boolean))
|
|
(validate (-> (context environment) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment) void)))
|
|
(production :for-initializer () for-initializer-empty
|
|
((validate (cxt :unused) (env :unused)))
|
|
((setup))
|
|
((eval (env :unused))))
|
|
(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-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-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-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-initializer 0)
|
|
((setup :variable-definition))))
|
|
((eval env)
|
|
(when (enabled :for-initializer 0)
|
|
(exec ((eval :variable-definition) env undefined))))))
|
|
|
|
|
|
(rule :for-in-binding ((validate (-> (context environment) void))
|
|
(setup (-> () void))
|
|
(write-binding (-> (environment object) void)))
|
|
(production :for-in-binding (:postfix-expression) for-in-binding-expression
|
|
((validate cxt env) ((validate :postfix-expression) cxt env))
|
|
((setup) ((setup :postfix-expression)))
|
|
((write-binding env new-value)
|
|
(const r obj-or-ref ((eval :postfix-expression) env run))
|
|
(exec (write-reference r new-value run))))
|
|
(production :for-in-binding (:variable-definition-kind (:variable-binding no-in)) for-in-binding-variable-definition
|
|
((validate cxt env) ((validate :variable-binding) cxt env none (immutable :variable-definition-kind) true))
|
|
((setup) ((setup :variable-binding)))
|
|
((write-binding env new-value) ((write-binding :variable-binding) env new-value)))
|
|
(production :for-in-binding (:attributes :no-line-break :variable-definition-kind (:variable-binding no-in)) for-in-binding-attribute-variable-definition
|
|
((validate cxt env)
|
|
((validate :attributes) cxt env)
|
|
((setup :attributes))
|
|
(const attr attribute ((eval :attributes) env compile))
|
|
(rwhen (in attr false-type :narrow-false)
|
|
(throw-error -attribute-error
|
|
"the " (:character-literal "false") " attribute canot be applied to a " (:character-literal "for") "-" (:character-literal "in") " variable definition"))
|
|
((validate :variable-binding) cxt env attr (immutable :variable-definition-kind) true))
|
|
((setup) ((setup :variable-binding)))
|
|
((write-binding env new-value) ((write-binding :variable-binding) env new-value))))
|
|
|
|
|
|
(rule :optional-expression ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) obj-or-ref)))
|
|
(production :optional-expression ((:list-expression allow-in)) optional-expression-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :list-expression) env phase))))
|
|
(production :optional-expression () optional-expression-empty
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return true))))
|
|
(%print-actions ("Validation" enabled labels compile-local-frame validate) ("Setup" setup) ("Evaluation" eval write-binding))
|
|
|
|
|
|
(%heading 2 "With Statement")
|
|
(rule (:with-statement :omega) ((compile-local-frame (writable-cell local-frame))
|
|
(validate (-> (context environment jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production (:with-statement :omega) (with :paren-list-expression (:substatement :omega)) with-statement-with
|
|
((validate cxt env jt)
|
|
((validate :paren-list-expression) cxt env)
|
|
(const compile-with-frame with-frame (new with-frame none))
|
|
(const compile-local-frame local-frame (new local-frame (list-set-of local-binding)))
|
|
(action<- (compile-local-frame :with-statement 0) compile-local-frame)
|
|
(const compile-env environment (cons compile-local-frame (cons compile-with-frame env)))
|
|
((validate :substatement) cxt compile-env (list-set-of label) jt))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(const value object (read-reference ((eval :paren-list-expression) env run) run))
|
|
(const runtime-with-frame with-frame (new with-frame value))
|
|
(const runtime-local-frame local-frame (instantiate-local-frame (compile-local-frame :with-statement 0) (cons runtime-with-frame env)))
|
|
(const runtime-env environment (cons runtime-local-frame (cons runtime-with-frame env)))
|
|
(return ((eval :substatement) runtime-env d)))))
|
|
(%print-actions ("Validation" compile-local-frame validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Continue and Break Statements")
|
|
(rule :continue-statement ((validate (-> (jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :continue-statement (continue) continue-statement-unlabeled
|
|
((validate jt)
|
|
(rwhen (set-not-in default (& continue-targets jt))
|
|
(throw-error -syntax-error "there is no enclosing statement to which to continue")))
|
|
((setup))
|
|
((eval (env :unused) d) (throw (new continue d default))))
|
|
(production :continue-statement (continue :no-line-break :identifier) continue-statement-labeled
|
|
((validate jt)
|
|
(rwhen (set-not-in (name :identifier) (& continue-targets jt))
|
|
(throw-error -syntax-error "there is no enclosing labeled statement to which to continue")))
|
|
((setup))
|
|
((eval (env :unused) d) (throw (new continue d (name :identifier))))))
|
|
|
|
(rule :break-statement ((validate (-> (jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :break-statement (break) break-statement-unlabeled
|
|
((validate jt)
|
|
(rwhen (set-not-in default (& break-targets jt))
|
|
(throw-error -syntax-error "there is no enclosing statement to which to break")))
|
|
((setup))
|
|
((eval (env :unused) d) (throw (new break d default))))
|
|
(production :break-statement (break :no-line-break :identifier) break-statement-labeled
|
|
((validate jt)
|
|
(rwhen (set-not-in (name :identifier) (& break-targets jt))
|
|
(throw-error -syntax-error "there is no enclosing labeled statement to which to break")))
|
|
((setup))
|
|
((eval (env :unused) d) (throw (new break d (name :identifier))))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Return Statement")
|
|
(rule :return-statement ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment) object)))
|
|
(production :return-statement (return) return-statement-default
|
|
((validate (cxt :unused) env)
|
|
(rwhen (in (get-enclosing-parameter-frame env) (tag none))
|
|
(throw-error -syntax-error "a " (:character-literal "return") " statement must be located inside a function")))
|
|
((setup) :forward)
|
|
((eval (env :unused)) (throw (new return undefined))))
|
|
(production :return-statement (return :no-line-break (:list-expression allow-in)) return-statement-expression
|
|
((validate cxt env)
|
|
(const frame parameter-frame-opt (get-enclosing-parameter-frame env))
|
|
(rwhen (in frame (tag none) :narrow-false)
|
|
(throw-error -syntax-error "a " (:character-literal "return") " statement must be located inside a function"))
|
|
(rwhen (cannot-return-value frame)
|
|
(throw-error -syntax-error "a " (:character-literal "return") " statement inside a setter or constructor cannot return a value"))
|
|
((validate :list-expression) cxt env))
|
|
((setup) :forward)
|
|
((eval env)
|
|
(const a object (read-reference ((eval :list-expression) env run) run))
|
|
(throw (new return a)))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
(%text :comment (:global-call cannot-return-value frame) " returns " (:tag true) " if the function represented by " (:local frame)
|
|
" cannot return a value because it is a setter or constructor.")
|
|
(define (cannot-return-value (frame parameter-frame)) boolean
|
|
(return (or (in (& kind frame) (tag constructor-function)) (in (& handling frame) (tag set)))))
|
|
|
|
|
|
(%heading 2 "Throw Statement")
|
|
(rule :throw-statement ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment) object)))
|
|
(production :throw-statement (throw :no-line-break (:list-expression allow-in)) throw-statement-throw
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env)
|
|
(const a object (read-reference ((eval :list-expression) env run) run))
|
|
(throw a))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Try Statement")
|
|
(rule :try-statement ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :try-statement (try :block :catch-clauses) try-statement-catch-clauses
|
|
((validate cxt env jt)
|
|
((validate :block) cxt env jt false)
|
|
((validate :catch-clauses) cxt env jt))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(catch ((return ((eval :block) env d)))
|
|
(x)
|
|
(cond
|
|
((in x control-transfer :narrow-false) (throw x))
|
|
(nil
|
|
(const r (union object (tag reject)) ((eval :catch-clauses) env x))
|
|
(if (not-in r (tag reject) :narrow-true)
|
|
(return r)
|
|
(throw x)))))))
|
|
|
|
(production :try-statement (try :block :catch-clauses-opt finally :block) try-statement-catch-clauses-finally
|
|
((validate cxt env jt)
|
|
((validate :block 1) cxt env jt false)
|
|
((validate :catch-clauses-opt) cxt env jt)
|
|
((validate :block 2) cxt env jt false))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(var result object-opt none)
|
|
(var exception (union semantic-exception (tag none)) none)
|
|
(catch ((<- result ((eval :block 1) env d)))
|
|
(x) (<- exception x))
|
|
(assert (xor (in result (tag none)) (in exception (tag none))) "At this point exactly one of " (:local result) " and " (:local exception) " has a non-" (:tag none) " value.")
|
|
(when (in exception object)
|
|
(catch ((const r (union object (tag reject)) ((eval :catch-clauses-opt) env (assert-in exception object)))
|
|
(when (not-in r (tag reject) :narrow-true)
|
|
(note "The exception has been handled, so clear it.")
|
|
(<- result r)
|
|
(<- exception none)))
|
|
(x)
|
|
(note "The " (:character-literal "catch") " clause threw another exception or " (:type control-transfer) " " (:local x) ", so replace the original exception with " (:local x) ".")
|
|
(<- exception x)))
|
|
(note "The " (:character-literal "finally") " clause is executed even if the original block exited due to a " (:type control-transfer) " ("
|
|
(:character-literal "break") ", " (:character-literal "continue") ", or " (:character-literal "return") ").")
|
|
(note "The " (:character-literal "finally") " clause is not inside a " (:keyword try) "-" (:keyword catch)
|
|
" semantic statement, so if it throws another exception or " (:type control-transfer) ", then the original exception or " (:type control-transfer) " "
|
|
(:local exception) " is dropped.")
|
|
(exec ((eval :block 2) env undefined))
|
|
(assert (xor (in result (tag none)) (in exception (tag none))) "At this point exactly one of " (:local result) " and " (:local exception) " has a non-" (:tag none) " value.")
|
|
(if (not-in exception (tag none) :narrow-true)
|
|
(throw exception)
|
|
(return (assert-not-in result (tag none)))))))
|
|
|
|
(rule :catch-clauses-opt ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) (union object (tag reject)))))
|
|
(production :catch-clauses-opt () catch-clauses-opt-none
|
|
((validate cxt env jt) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) (exception :unused))
|
|
(return reject)))
|
|
(production :catch-clauses-opt (:catch-clauses) catch-clauses-opt-some
|
|
((validate cxt env jt) :forward)
|
|
((setup) :forward)
|
|
((eval env exception)
|
|
(return ((eval :catch-clauses) env exception)))))
|
|
|
|
(rule :catch-clauses ((validate (-> (context environment jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) (union object (tag reject)))))
|
|
(production :catch-clauses (:catch-clause) catch-clauses-one
|
|
((validate cxt env jt) :forward)
|
|
((setup) :forward)
|
|
((eval env exception)
|
|
(return ((eval :catch-clause) env exception))))
|
|
(production :catch-clauses (:catch-clauses :catch-clause) catch-clauses-more
|
|
((validate cxt env jt) :forward)
|
|
((setup) :forward)
|
|
((eval env exception)
|
|
(const r (union object (tag reject)) ((eval :catch-clauses) env exception))
|
|
(if (not-in r (tag reject) :narrow-true)
|
|
(return r)
|
|
(return ((eval :catch-clause) env exception))))))
|
|
|
|
(rule :catch-clause ((compile-env (writable-cell environment))
|
|
(compile-frame (writable-cell local-frame))
|
|
(validate (-> (context environment jump-targets) void)) (setup (-> () void))
|
|
(eval (-> (environment object) (union object (tag reject)))))
|
|
(production :catch-clause (catch \( :parameter \) :block) catch-clause-block
|
|
((validate cxt env jt)
|
|
(const compile-frame local-frame (new local-frame (list-set-of local-binding)))
|
|
(const compile-env environment (cons compile-frame env))
|
|
(action<- (compile-frame :catch-clause 0) compile-frame)
|
|
(action<- (compile-env :catch-clause 0) compile-env)
|
|
((validate :parameter) cxt compile-env compile-frame)
|
|
((validate :block) cxt compile-env jt false))
|
|
((setup)
|
|
((setup :parameter) (compile-env :catch-clause 0) (compile-frame :catch-clause 0) none)
|
|
((setup :block)))
|
|
((eval env exception)
|
|
(const compile-frame local-frame (compile-frame :catch-clause 0))
|
|
(const runtime-frame local-frame (instantiate-local-frame compile-frame env))
|
|
(const runtime-env environment (cons runtime-frame env))
|
|
(const qname qualified-name (new qualified-name public (name :parameter)))
|
|
(const v singleton-property-opt (find-local-singleton-property runtime-frame (list-set qname) write))
|
|
(assert (in v variable :narrow-true) (:action validate) " created one local variable with the name in " (:local qname) ", so " (:assertion) ".")
|
|
(cond
|
|
((is exception (&opt type v))
|
|
(write-singleton-property v exception run)
|
|
(return ((eval :block) runtime-env undefined)))
|
|
(nil (return reject))))))
|
|
(%print-actions ("Validation" compile-env compile-frame validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 1 "Directives")
|
|
(rule (:directive :omega_2) ((enabled (writable-cell boolean))
|
|
(validate (-> (context environment jump-targets boolean attribute-opt-not-false) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production (:directive :omega_2) (:empty-statement) directive-empty-statement
|
|
((validate (cxt :unused) (env :unused) (jt :unused) (preinst :unused) (attr :unused)))
|
|
((setup))
|
|
((eval (env :unused) d) (return d)))
|
|
(production (:directive :omega_2) ((:statement :omega_2)) directive-statement
|
|
((validate cxt env jt preinst attr)
|
|
(rwhen (not-in attr (tag none true))
|
|
(throw-error -attribute-error "an ordinary statement only permits the attributes " (:character-literal "true") " and " (:character-literal "false")))
|
|
((validate :statement) cxt env (list-set-of label) jt preinst))
|
|
((setup) ((setup :statement)))
|
|
((eval env d) (return ((eval :statement) env d))))
|
|
(production (:directive :omega_2) ((:annotatable-directive :omega_2)) directive-annotatable-directive
|
|
((validate cxt env (jt :unused) preinst attr) ((validate :annotatable-directive) cxt env preinst attr))
|
|
((setup) ((setup :annotatable-directive)))
|
|
((eval env d) (return ((eval :annotatable-directive) env d))))
|
|
(production (:directive :omega_2) (:attributes :no-line-break (:annotatable-directive :omega_2)) directive-attributes-and-directive
|
|
((validate cxt env (jt :unused) preinst attr)
|
|
((validate :attributes) cxt env)
|
|
((setup :attributes))
|
|
(const attr2 attribute ((eval :attributes) env compile))
|
|
(const attr3 attribute (combine-attributes attr attr2))
|
|
(cond
|
|
((in attr3 false-type :narrow-false)
|
|
(action<- (enabled :directive 0) false))
|
|
(nil
|
|
(action<- (enabled :directive 0) true)
|
|
((validate :annotatable-directive) cxt env preinst attr3))))
|
|
((setup)
|
|
(when (enabled :directive 0)
|
|
((setup :annotatable-directive))))
|
|
((eval env d)
|
|
(if (enabled :directive 0)
|
|
(return ((eval :annotatable-directive) env d))
|
|
(return d))))
|
|
(production (:directive :omega_2) (:attributes :no-line-break { :directives }) directive-annotated-group
|
|
((validate cxt env jt preinst attr)
|
|
((validate :attributes) cxt env)
|
|
((setup :attributes))
|
|
(const attr2 attribute ((eval :attributes) env compile))
|
|
(const attr3 attribute (combine-attributes attr attr2))
|
|
(cond
|
|
((in attr3 false-type :narrow-false)
|
|
(action<- (enabled :directive 0) false))
|
|
(nil
|
|
(action<- (enabled :directive 0) true)
|
|
(const local-cxt context (new context (& strict cxt) (& open-namespaces cxt)))
|
|
((validate :directives) local-cxt env jt preinst attr3))))
|
|
((setup)
|
|
(when (enabled :directive 0)
|
|
((setup :directives))))
|
|
((eval env d)
|
|
(if (enabled :directive 0)
|
|
(return ((eval :directives) env d))
|
|
(return d))))
|
|
(? js2
|
|
(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))
|
|
(todo)
|
|
(throw-error -attribute-error "an " (:character-literal "include") " directive only permits the attributes " (:character-literal "true") " and " (:character-literal "false"))))
|
|
((setup) (todo))
|
|
((eval (env :unused) (d :unused)) (todo))))
|
|
(production (:directive :omega_2) (:pragma (:semicolon :omega_2)) directive-pragma
|
|
((validate cxt (env :unused) (jt :unused) (preinst :unused) attr)
|
|
(if (in attr (tag none true))
|
|
((validate :pragma) cxt)
|
|
(throw-error -attribute-error "a " (:character-literal "pragma") " directive only permits the attributes " (:character-literal "true") " and " (:character-literal "false"))))
|
|
((setup))
|
|
((eval (env :unused) d) (return d))))
|
|
|
|
(rule (:annotatable-directive :omega_2) ((validate (-> (context environment boolean attribute-opt-not-false) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production (:annotatable-directive :omega_2) ((:variable-definition allow-in) (:semicolon :omega_2)) annotatable-directive-variable-definition
|
|
((validate cxt env (preinst :unused) attr) ((validate :variable-definition) cxt env attr))
|
|
((setup) ((setup :variable-definition)))
|
|
((eval env d) (return ((eval :variable-definition) env d))))
|
|
(production (:annotatable-directive :omega_2) (:function-definition) annotatable-directive-function-definition
|
|
((validate cxt env preinst attr) ((validate :function-definition) cxt env preinst attr))
|
|
((setup) ((setup :function-definition)))
|
|
((eval (env :unused) d) (return d)))
|
|
(production (:annotatable-directive :omega_2) (:class-definition) annotatable-directive-class-definition
|
|
((validate cxt env preinst attr) ((validate :class-definition) cxt env preinst attr))
|
|
((setup) ((setup :class-definition)))
|
|
((eval env d) (return ((eval :class-definition) env d))))
|
|
(production (:annotatable-directive :omega_2) (:namespace-definition (:semicolon :omega_2)) annotatable-directive-namespace-definition
|
|
((validate cxt env preinst attr) ((validate :namespace-definition) cxt env preinst attr))
|
|
((setup))
|
|
((eval (env :unused) d) (return d)))
|
|
;(production (:annotatable-directive :omega_2) ((:interface-definition :omega_2)) annotatable-directive-interface-definition
|
|
; ((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) (:export-definition (:semicolon :omega_2)) annotatable-directive-export-definition
|
|
((validate (cxt :unused) (env :unused) (preinst :unused) (attr :unused)) (todo))
|
|
((setup) (todo))
|
|
((eval (env :unused) (d :unused)) (todo))))
|
|
(production (:annotatable-directive :omega_2) (:use-directive (:semicolon :omega_2)) annotatable-directive-use-directive
|
|
((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"))))
|
|
((setup))
|
|
((eval (env :unused) d) (return d))))
|
|
|
|
|
|
(rule :directives ((validate (-> (context environment jump-targets boolean attribute-opt-not-false) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :directives () directives-none
|
|
((validate cxt env jt preinst attr) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) d) (return d)))
|
|
(production :directives (:directives-prefix (:directive abbrev)) directives-more
|
|
((validate cxt env jt preinst attr) :forward)
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(const o object ((eval :directives-prefix) env d))
|
|
(return ((eval :directive) env o)))))
|
|
|
|
(rule :directives-prefix ((validate (-> (context environment jump-targets boolean attribute-opt-not-false) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :directives-prefix () directives-prefix-none
|
|
((validate cxt env jt preinst attr) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) d) (return d)))
|
|
(production :directives-prefix (:directives-prefix (:directive full)) directives-prefix-more
|
|
((validate cxt env jt preinst attr) :forward)
|
|
((setup) :forward)
|
|
((eval env d)
|
|
(const o object ((eval :directives-prefix) env d))
|
|
(return ((eval :directive) env o)))))
|
|
(%print-actions ("Validation" enabled validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
(%heading 2 "Attributes")
|
|
(rule :attributes ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) attribute)))
|
|
(production :attributes (:attribute) attributes-one
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :attribute) env phase))))
|
|
(production :attributes (:attribute-combination) attributes-attribute-combination
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :attribute-combination) env phase)))))
|
|
|
|
|
|
(rule :attribute-combination ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) attribute)))
|
|
(production :attribute-combination (:attribute :no-line-break :attributes) attribute-combination-more
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a attribute ((eval :attribute) env phase))
|
|
(rwhen (in a false-type :narrow-false)
|
|
(return false))
|
|
(const b attribute ((eval :attributes) env phase))
|
|
(return (combine-attributes a b)))))
|
|
|
|
|
|
(rule :attribute ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) attribute)))
|
|
(production :attribute (:attribute-expression) attribute-attribute-expression
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase)
|
|
(const a object (read-reference ((eval :attribute-expression) env phase) phase))
|
|
(return (object-to-attribute a phase))))
|
|
(production :attribute (true) attribute-true
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return true)))
|
|
(production :attribute (false) attribute-false
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval (env :unused) (phase :unused)) (return false)))
|
|
(production :attribute (:reserved-namespace) attribute-reserved-namespace
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :reserved-namespace) env phase)))))
|
|
(%print-actions ("Validation" validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
|
|
(%heading 2 "Use Directive")
|
|
(rule :use-directive ((validate (-> (context environment) void)))
|
|
(production :use-directive (use namespace :paren-list-expression) use-directive-normal
|
|
((validate cxt env)
|
|
((validate :paren-list-expression) cxt env)
|
|
((setup :paren-list-expression))
|
|
(const values (vector object) ((eval-as-list :paren-list-expression) env compile))
|
|
(var namespaces (list-set namespace) (list-set-of namespace))
|
|
(for-each values v
|
|
(rwhen (not-in v namespace :narrow-false)
|
|
(throw-error -type-error))
|
|
(<- namespaces (set+ namespaces (list-set v))))
|
|
(&= open-namespaces cxt (set+ (& open-namespaces cxt) namespaces)))))
|
|
(%print-actions ("Validation" validate))
|
|
|
|
|
|
(%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 (:package-name) import-binding-import-source)
|
|
(production :import-binding (:identifier = :package-name) import-binding-named-import-source)
|
|
|
|
|
|
(production :includes-excludes () includes-excludes-none)
|
|
(production :includes-excludes (\, exclude \( :name-patterns \)) includes-excludes-exclude-list)
|
|
(production :includes-excludes (\, include \( :name-patterns \)) includes-excludes-include-list)
|
|
|
|
(production :name-patterns () name-patterns-empty)
|
|
(production :name-patterns (:name-pattern-list) name-patterns-name-pattern-list)
|
|
|
|
(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)
|
|
|
|
(production :name-pattern (:qualified-wildcard-pattern) name-pattern-qualified-wildcard-pattern)
|
|
(production :name-pattern (:full-postfix-expression \. :qualified-wildcard-pattern) name-pattern-dot-qualified-wildcard-pattern)
|
|
(production :name-pattern (:attribute-expression \. :qualified-wildcard-pattern) name-pattern-dot-qualified-wildcard-pattern2)
|
|
|
|
(production :qualified-wildcard-pattern (:qualified-identifier) qualified-wildcard-pattern-qualified-identifier)
|
|
(production :qualified-wildcard-pattern (:wildcard-pattern) qualified-wildcard-pattern-wildcard-pattern)
|
|
(production :qualified-wildcard-pattern (:qualifier \:\: :wildcard-pattern) qualified-wildcard-pattern-qualifier)
|
|
(production :qualified-wildcard-pattern (:paren-expression \:\: :wildcard-pattern) qualified-wildcard-pattern-expression-qualifier)
|
|
|
|
(production :wildcard-pattern (*) wildcard-pattern-all)
|
|
(production :wildcard-pattern ($regular-expression) wildcard-pattern-regular-expression)
|
|
|#
|
|
|
|
|
|
(? js2
|
|
(%heading 2 "Include Directive")
|
|
(production :include-directive (include :no-line-break $string) include-directive-include))
|
|
|
|
|
|
(%heading 2 "Pragma")
|
|
(rule :pragma ((validate (-> (context) void)))
|
|
(production :pragma (use :pragma-items) pragma-pragma-items
|
|
((validate cxt) :forward)))
|
|
|
|
(rule :pragma-items ((validate (-> (context) void)))
|
|
(production :pragma-items (:pragma-item) pragma-items-one
|
|
((validate cxt) :forward))
|
|
(production :pragma-items (:pragma-items \, :pragma-item) pragma-items-more
|
|
((validate cxt) :forward)))
|
|
|
|
(rule :pragma-item ((validate (-> (context) void)))
|
|
(production :pragma-item (:pragma-expr) pragma-item-pragma-expr
|
|
((validate cxt) ((validate :pragma-expr) cxt false)))
|
|
(production :pragma-item (:pragma-expr \?) pragma-item-optional-pragma-expr
|
|
((validate cxt) ((validate :pragma-expr) cxt true))))
|
|
|
|
(rule :pragma-expr ((validate (-> (context boolean) void)))
|
|
(production :pragma-expr (:identifier) pragma-expr-identifier
|
|
((validate cxt optional)
|
|
(process-pragma cxt (name :identifier) undefined optional)))
|
|
(production :pragma-expr (:identifier \( :pragma-argument \)) pragma-expr-identifier-and-parameter
|
|
((validate cxt optional)
|
|
(const arg object (value :pragma-argument))
|
|
(process-pragma cxt (name :identifier) arg optional))))
|
|
|
|
(rule :pragma-argument ((value object))
|
|
(production :pragma-argument (true) pragma-argument-true (value true))
|
|
(production :pragma-argument (false) pragma-argument-false (value false))
|
|
(production :pragma-argument ($number) pragma-argument-number (value (value $number)))
|
|
(production :pragma-argument (- $number) pragma-argument-negative-number (value (general-number-negate (value $number))))
|
|
(production :pragma-argument (- $negated-min-long) pragma-argument-min-long (value (new long (neg (expt 2 63)))))
|
|
(production :pragma-argument ($string) pragma-argument-string (value (value $string))))
|
|
(%print-actions ("Validation" validate))
|
|
|
|
(define (process-pragma (cxt context) (name string) (value object) (optional boolean)) void
|
|
(when (= name "strict" string)
|
|
(rwhen (in value (tag true undefined) :narrow-false)
|
|
(&= strict cxt true)
|
|
(return))
|
|
(rwhen (in value (tag false))
|
|
(&= strict cxt false)
|
|
(return)))
|
|
(when (= name "ecmascript" string)
|
|
(rwhen (set-in value (list-set-of object undefined 4.0))
|
|
(return))
|
|
(rwhen (set-in value (list-set-of object 1.0 2.0 3.0))
|
|
(// "An implementation may optionally modify " (:local cxt) " to disable features not available in ECMAScript Edition " (:local value)
|
|
" other than subsequent pragmas.")
|
|
(return)))
|
|
(rwhen (not optional)
|
|
(throw-error -syntax-error)))
|
|
|
|
|
|
(%heading 1 "Definitions")
|
|
(? js2
|
|
(%heading 2 "Export Definition")
|
|
(production :export-definition (export :export-binding-list) export-definition-definition)
|
|
|
|
(production :export-binding-list (:export-binding) export-binding-list-one)
|
|
(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-initializer))
|
|
|
|
|
|
(%heading 2 "Variable Definition")
|
|
(rule (:variable-definition :beta) ((validate (-> (context environment attribute-opt-not-false) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production (:variable-definition :beta) (:variable-definition-kind (:variable-binding-list :beta)) variable-definition-definition
|
|
((validate cxt env attr)
|
|
((validate :variable-binding-list) cxt env attr (immutable :variable-definition-kind) false))
|
|
((setup) ((setup :variable-binding-list)))
|
|
((eval env d)
|
|
((eval :variable-binding-list) env)
|
|
(return d))))
|
|
|
|
(rule :variable-definition-kind ((immutable boolean))
|
|
(production :variable-definition-kind (var) variable-definition-kind-var (immutable false))
|
|
(production :variable-definition-kind (const) variable-definition-kind-const (immutable true)))
|
|
|
|
(rule (:variable-binding-list :beta) ((validate (-> (context environment attribute-opt-not-false boolean boolean) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment) void)))
|
|
(production (:variable-binding-list :beta) ((:variable-binding :beta)) variable-binding-list-one
|
|
((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-initializer) :forward)
|
|
((setup) :forward)
|
|
((eval env) :forward)))
|
|
|
|
|
|
(rule (:variable-binding :beta) ((compile-env (writable-cell environment))
|
|
(compile-var (writable-cell (union variable dynamic-var instance-variable)))
|
|
(overridden-var (writable-cell instance-variable-opt))
|
|
(multiname (writable-cell multiname))
|
|
(validate (-> (context environment attribute-opt-not-false boolean boolean) void))
|
|
(setup (-> () void))
|
|
(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-initializer)
|
|
((validate :typed-identifier) cxt env)
|
|
((validate :variable-initialisation) cxt env)
|
|
(action<- (compile-env :variable-binding 0) env)
|
|
(const name string (name :typed-identifier))
|
|
(cond
|
|
((and (not (& strict cxt)) (in (get-regional-frame env) (union package parameter-frame))
|
|
(not immutable) (in attr (tag none)) (plain :typed-identifier))
|
|
(const qname qualified-name (new qualified-name public name))
|
|
(action<- (multiname :variable-binding 0) (list-set qname))
|
|
(action<- (compile-var :variable-binding 0) (define-hoisted-var env name undefined)))
|
|
(nil
|
|
(const a compound-attribute (to-compound-attribute attr))
|
|
(rwhen (& dynamic a)
|
|
(throw-error -attribute-error "a variable definition cannot have the " (:character-literal "dynamic") " attribute"))
|
|
(rwhen (& prototype a)
|
|
(throw-error -attribute-error "a variable definition cannot have the " (:character-literal "prototype") " attribute"))
|
|
(var category property-category (& category a))
|
|
(if (in (nth env 0) class)
|
|
(when (in category (tag none))
|
|
(<- category final))
|
|
(rwhen (not-in category (tag none))
|
|
(throw-error -attribute-error
|
|
"non-class variables cannot have a " (:character-literal "static") ", " (:character-literal "virtual") ", or "
|
|
(:character-literal "final") " attribute")))
|
|
(case category
|
|
(:select (tag none static)
|
|
(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 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-initializer))
|
|
(const c class (assert-in (nth env 0) class))
|
|
(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)
|
|
(const env environment (compile-env :variable-binding 0))
|
|
(const v (union variable dynamic-var instance-variable) (compile-var :variable-binding 0))
|
|
(case v
|
|
(:narrow variable
|
|
(setup-variable v)
|
|
(when (not (& immutable v))
|
|
(const default-value object-opt (& default-value (&opt type v)))
|
|
(rwhen (in default-value (tag none) :narrow-false)
|
|
(throw-error -uninitialized-error "Cannot declare a mutable variable of type " (:character-literal "Never")))
|
|
(&= value v default-value)))
|
|
(:select dynamic-var
|
|
((setup :variable-initialisation)))
|
|
(:narrow instance-variable
|
|
(var t class-opt ((setup-and-eval :typed-identifier) env))
|
|
(when (in t (tag none))
|
|
(const overridden-var instance-variable-opt (overridden-var :variable-binding 0))
|
|
(if (not-in overridden-var (tag none) :narrow-true)
|
|
(<- t (&opt type overridden-var))
|
|
(<- t -object)))
|
|
(quiet-assert (not-in t (tag none) :narrow-true))
|
|
(&const= type v t)
|
|
((setup :variable-initialisation))
|
|
(const initializer initializer-opt (initializer :variable-initialisation))
|
|
(var default-value object-opt none)
|
|
(cond
|
|
((not-in initializer (tag none) :narrow-true)
|
|
(<- default-value (initializer env compile)))
|
|
((not (& immutable v))
|
|
(<- 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))))
|
|
|
|
((eval env)
|
|
(case (compile-var :variable-binding 0)
|
|
(:select variable
|
|
(const inner-frame non-with-frame (assert-not-in (nth env 0) with-frame))
|
|
(const properties (list-set singleton-property) (map (& local-bindings inner-frame) b (& content b) (set-in (& qname b) (multiname :variable-binding 0))))
|
|
(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 initializer (union initializer (tag none busy)) (& initializer v))
|
|
(case initializer
|
|
(:select (tag none))
|
|
(:select (tag busy) (throw-error -reference-error))
|
|
(:narrow initializer
|
|
(&= initializer v busy)
|
|
(const value object (initializer (&opt initializer-env v) run))
|
|
(exec (write-variable v value true)))))
|
|
(:select dynamic-var
|
|
(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)))
|
|
|
|
((write-binding env new-value)
|
|
(case (assert-not-in (compile-var :variable-binding 0) instance-variable)
|
|
(:select variable
|
|
(const inner-frame non-with-frame (assert-not-in (nth env 0) with-frame))
|
|
(const properties (list-set singleton-property) (map (& local-bindings inner-frame) b (& content b) (set-in (& qname b) (multiname :variable-binding 0))))
|
|
(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))
|
|
(exec (write-variable v new-value false)))
|
|
(:select dynamic-var
|
|
(lexical-write env (multiname :variable-binding 0) new-value false run))))))
|
|
|
|
|
|
(rule (:variable-initialisation :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(initializer initializer-opt))
|
|
(production (:variable-initialisation :beta) () variable-initialisation-none
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
(initializer none))
|
|
(production (:variable-initialisation :beta) (= (:variable-initializer :beta)) variable-initialisation-variable-initializer
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
(initializer (eval :variable-initializer))))
|
|
|
|
(rule (:variable-initializer :beta) ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment phase) object)))
|
|
(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-initializer :beta) (:attribute-combination) variable-initializer-attribute-combination
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env phase) (return ((eval :attribute-combination) env phase)))))
|
|
|
|
|
|
(rule (:typed-identifier :beta) ((name string) (plain boolean)
|
|
(validate (-> (context environment) void))
|
|
(setup-and-eval (-> (environment) class-opt)))
|
|
(production (:typed-identifier :beta) (:identifier) typed-identifier-identifier
|
|
(name (name :identifier))
|
|
(plain true)
|
|
((validate (cxt :unused) (env :unused)))
|
|
((setup-and-eval (env :unused)) (return none)))
|
|
(production (:typed-identifier :beta) (:identifier \: (:type-expression :beta)) typed-identifier-identifier-and-type
|
|
(name (name :identifier))
|
|
(plain false)
|
|
((validate cxt env) ((validate :type-expression) cxt env))
|
|
((setup-and-eval env) (return ((setup-and-eval :type-expression) env)))))
|
|
;(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 initializer))
|
|
|
|
|
|
(%heading 2 "Simple Variable Definition")
|
|
(%text :syntax "A " (:grammar-symbol :simple-variable-definition) " represents the subset of " (:grammar-symbol :variable-definition)
|
|
" expansions that may be used when the variable definition is used as a " (:grammar-symbol (:substatement :omega))
|
|
" instead of a " (:grammar-symbol (:directive :omega_2)) " in non-strict mode. "
|
|
"In strict mode variable definitions may not be used as substatements.")
|
|
(rule :simple-variable-definition ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :simple-variable-definition (var :untyped-variable-binding-list) simple-variable-definition-definition
|
|
((validate cxt env)
|
|
(rwhen (or (& strict cxt) (not-in (get-regional-frame env) (union package parameter-frame)))
|
|
(throw-error -syntax-error
|
|
"a variable may not be defined in a substatement except inside a non-strict function or non-strict top-level code; "
|
|
"to fix this error, place the definition inside a block"))
|
|
((validate :untyped-variable-binding-list) cxt env))
|
|
((setup) :forward)
|
|
((eval env d)
|
|
((eval :untyped-variable-binding-list) env)
|
|
(return d))))
|
|
|
|
(rule :untyped-variable-binding-list ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment) void)))
|
|
(production :untyped-variable-binding-list (:untyped-variable-binding) untyped-variable-binding-list-one
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env) :forward))
|
|
(production :untyped-variable-binding-list (:untyped-variable-binding-list \, :untyped-variable-binding) untyped-variable-binding-list-more
|
|
((validate cxt env) :forward)
|
|
((setup) :forward)
|
|
((eval env) :forward)))
|
|
|
|
(rule :untyped-variable-binding ((validate (-> (context environment) void)) (setup (-> () void))
|
|
(eval (-> (environment) void)))
|
|
(production :untyped-variable-binding (:identifier (:variable-initialisation allow-in)) untyped-variable-binding-full
|
|
((validate cxt env)
|
|
((validate :variable-initialisation) cxt env)
|
|
(exec (define-hoisted-var env (name :identifier) undefined)))
|
|
((setup) ((setup :variable-initialisation)))
|
|
((eval env)
|
|
(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))
|
|
|
|
|
|
(%heading 2 "Function Definition")
|
|
(rule :function-definition ((overridden-property (writable-cell instance-property-opt))
|
|
(validate-static (-> (context environment boolean compound-attribute boolean boolean) void))
|
|
(validate-instance (-> (context environment class compound-attribute boolean) void))
|
|
(validate-constructor (-> (context environment class compound-attribute) void))
|
|
(validate (-> (context environment boolean attribute-opt-not-false) void))
|
|
(setup (-> () void)))
|
|
(production :function-definition (function :function-name :function-common) function-definition-definition
|
|
((validate-static cxt env preinst a unchecked hoisted)
|
|
(const name string (name :function-name))
|
|
(const handling handling (handling :function-name))
|
|
(case handling
|
|
(:select (tag normal)
|
|
(var kind static-function-kind)
|
|
(cond
|
|
(unchecked (<- kind unchecked-function))
|
|
((& prototype a) (<- kind prototype-function))
|
|
(nil (<- kind plain-function)))
|
|
(var f (union simple-instance uninstantiated-function) ((validate-static-function :function-common) cxt env kind))
|
|
(when preinst
|
|
(<- f (instantiate-function (assert-in f uninstantiated-function) env)))
|
|
(cond
|
|
(hoisted
|
|
(exec (define-hoisted-var env name f)))
|
|
(nil
|
|
(const v variable (new variable -function f true none none :uninit))
|
|
(exec (define-singleton-property env name (& namespaces a) (& override-mod a) (& explicit a) read-write v)))))
|
|
(:narrow (tag get set)
|
|
(rwhen (& prototype a)
|
|
(throw-error -attribute-error "a getter or setter cannot have the " (:character-literal "prototype") " attribute"))
|
|
(assert (not (or unchecked hoisted)))
|
|
((validate :function-common) cxt env plain-function handling)
|
|
(var bound-env environment-opt none)
|
|
(when preinst
|
|
(<- bound-env env))
|
|
(case handling
|
|
(:select (tag get)
|
|
(const getter getter (new getter (eval-static-get :function-common) bound-env))
|
|
(exec (define-singleton-property env name (& namespaces a) (& override-mod a) (& explicit a) read getter)))
|
|
(:select (tag set)
|
|
(const setter setter (new setter (eval-static-set :function-common) bound-env))
|
|
(exec (define-singleton-property env name (& namespaces a) (& override-mod a) (& explicit a) write setter))))))
|
|
(action<- (overridden-property :function-definition 0) none))
|
|
|
|
((validate-instance cxt env c a final)
|
|
(rwhen (& prototype a)
|
|
(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 :uninit signature (signature-length signature) (eval-instance-call :function-common))))
|
|
(:select (tag get)
|
|
(<- m (new instance-getter :uninit final :uninit signature (eval-instance-get :function-common))))
|
|
(:select (tag set)
|
|
(<- 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)
|
|
(throw-error -attribute-error "a class constructor cannot have the " (:character-literal "prototype") " attribute"))
|
|
(rwhen (in (handling :function-name) (tag get set))
|
|
(throw-error -syntax-error "a class constructor cannot be a getter or a setter"))
|
|
((validate :function-common) cxt env constructor-function normal)
|
|
(rwhen (not-in (& init c) (tag none))
|
|
(throw-error -definition-error "duplicate constructor definition"))
|
|
(&= init c (eval-instance-init :function-common))
|
|
(action<- (overridden-property :function-definition 0) none))
|
|
|
|
((validate cxt env preinst attr)
|
|
(const a compound-attribute (to-compound-attribute attr))
|
|
(rwhen (& dynamic a)
|
|
(throw-error -attribute-error "a function cannot have the " (:character-literal "dynamic") " attribute"))
|
|
(const frame frame (nth env 0))
|
|
(cond
|
|
((in frame class :narrow-true)
|
|
(assert preinst)
|
|
(case (& category a)
|
|
(:select (tag static)
|
|
((validate-static :function-definition 0) cxt env preinst a false false))
|
|
(:select (tag none)
|
|
(if (= (name :function-name) (& name frame) string)
|
|
((validate-constructor :function-definition 0) cxt env frame a)
|
|
((validate-instance :function-definition 0) cxt env frame a false)))
|
|
(:select (tag virtual)
|
|
((validate-instance :function-definition 0) cxt env frame a false))
|
|
(:select (tag final)
|
|
((validate-instance :function-definition 0) cxt env frame a true))))
|
|
(nil
|
|
(rwhen (not-in (& category a) (tag none))
|
|
(throw-error -attribute-error
|
|
"non-class functions cannot have a " (:character-literal "static") ", " (:character-literal "virtual") ", or "
|
|
(:character-literal "final") " attribute"))
|
|
(const unchecked boolean (and (not (& strict cxt)) (in (handling :function-name) (tag normal)) (plain :function-common)))
|
|
(const hoisted boolean (and unchecked
|
|
(in attr (tag none))
|
|
(or (in frame package) (and (in frame local-frame) (in (nth env 1) parameter-frame)))))
|
|
((validate-static :function-definition 0) cxt env preinst a unchecked hoisted))))
|
|
|
|
((setup)
|
|
(const overridden-property instance-property-opt (overridden-property :function-definition 0))
|
|
(case overridden-property
|
|
(:select (tag none)
|
|
((setup :function-common)))
|
|
(:narrow (union instance-method instance-getter instance-setter)
|
|
((setup-override :function-common) (&opt signature overridden-property)))
|
|
(:narrow instance-variable
|
|
(var overridden-signature parameter-frame)
|
|
(case (handling :function-name)
|
|
(:select (tag normal)
|
|
(bottom "This cannot happen because " (:action validate-instance) " already ensured that a function cannot override an instance variable."))
|
|
(:select (tag get)
|
|
(<- overridden-signature (new parameter-frame (list-set-of local-binding) instance-function get false false none
|
|
(vector-of parameter) none (&opt type overridden-property))))
|
|
(:select (tag set)
|
|
(const v variable (new variable (&opt type overridden-property) none false none none :uninit))
|
|
(const parameters (vector parameter) (vector (new parameter v none)))
|
|
(<- overridden-signature (new parameter-frame (list-set-of local-binding) instance-function set false false none
|
|
parameters none -void))))
|
|
((setup-override :function-common) overridden-signature))))))
|
|
|
|
|
|
(rule :function-name ((handling handling) (name string))
|
|
(production :function-name (:identifier) function-name-function
|
|
(handling normal)
|
|
(name (name :identifier)))
|
|
(production :function-name (get :no-line-break :identifier) function-name-getter
|
|
(handling get)
|
|
(name (name :identifier)))
|
|
(production :function-name (set :no-line-break :identifier) function-name-setter
|
|
(handling set)
|
|
(name (name :identifier))))
|
|
|
|
|
|
(rule :function-common ((plain boolean)
|
|
(compile-env (writable-cell environment))
|
|
(compile-frame (writable-cell parameter-frame))
|
|
(validate (-> (context environment function-kind handling) void))
|
|
(setup (-> () void))
|
|
(setup-override (-> (parameter-frame) void))
|
|
(eval-static-call (-> (object simple-instance (vector object) phase) object))
|
|
(eval-static-get (-> (environment phase) object))
|
|
(eval-static-set (-> (object environment phase) void))
|
|
(eval-instance-call (-> (object (vector object) phase) object))
|
|
(eval-instance-get (-> (object phase) object))
|
|
(eval-instance-set (-> (object object phase) void))
|
|
(eval-instance-init (-> (simple-instance (vector object) (tag run)) void))
|
|
(eval-prototype-construct (-> (simple-instance (vector object) phase) object))
|
|
(validate-static-function (-> (context environment static-function-kind) uninstantiated-function)))
|
|
(production :function-common (\( :parameters \) :result :block) function-common-signatures-and-block
|
|
(plain (and (plain :parameters) (plain :result)))
|
|
((validate cxt env kind handling)
|
|
(const local-cxt context (new context (& strict cxt) (& open-namespaces cxt)))
|
|
(const superconstructor-called boolean (not-in kind (tag constructor-function)))
|
|
(const compile-frame parameter-frame (new parameter-frame (list-set-of local-binding) kind handling false superconstructor-called none
|
|
(vector-of parameter) none :uninit))
|
|
(const compile-env environment (cons compile-frame env))
|
|
(action<- (compile-frame :function-common 0) compile-frame)
|
|
(action<- (compile-env :function-common 0) compile-env)
|
|
(when (in kind (tag unchecked-function))
|
|
(exec (define-hoisted-var compile-env "arguments" undefined)))
|
|
((validate :parameters) local-cxt compile-env compile-frame)
|
|
((validate :result) local-cxt compile-env)
|
|
((validate :block) local-cxt compile-env (new jump-targets (list-set-of label) (list-set-of label)) false))
|
|
|
|
((setup)
|
|
(const compile-env environment (compile-env :function-common 0))
|
|
(const compile-frame parameter-frame (compile-frame :function-common 0))
|
|
((setup :parameters) compile-env compile-frame)
|
|
(check-accessor-parameters compile-frame)
|
|
((setup :result) compile-env compile-frame)
|
|
((setup :block)))
|
|
|
|
((setup-override overridden-signature)
|
|
(const compile-env environment (compile-env :function-common 0))
|
|
(const compile-frame parameter-frame (compile-frame :function-common 0))
|
|
((setup-override :parameters) compile-env compile-frame overridden-signature)
|
|
(check-accessor-parameters compile-frame)
|
|
((setup-override :result) compile-env compile-frame overridden-signature)
|
|
((setup :block)))
|
|
|
|
((eval-static-call this f args phase)
|
|
(note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "a constant expression cannot call user-defined functions"))
|
|
(const runtime-env environment (assert-not-in (& env f) (tag none)))
|
|
(var runtime-this object-opt none)
|
|
(const compile-frame parameter-frame (compile-frame :function-common 0))
|
|
(when (in (& kind compile-frame) (tag unchecked-function prototype-function))
|
|
(if (in this primitive-object)
|
|
(<- runtime-this (get-package-frame runtime-env))
|
|
(<- runtime-this this)))
|
|
(const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame runtime-env runtime-this))
|
|
(assign-arguments runtime-frame f args phase)
|
|
(var result object)
|
|
(catch ((exec ((eval :block) (cons runtime-frame runtime-env) undefined))
|
|
(<- result undefined))
|
|
(x) (if (in x return :narrow-true)
|
|
(<- result (& value x))
|
|
(throw x)))
|
|
(return (coerce result (&opt return-type runtime-frame))))
|
|
|
|
((eval-static-get runtime-env phase)
|
|
(note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "a constant expression cannot call user-defined getters"))
|
|
(const compile-frame parameter-frame (compile-frame :function-common 0))
|
|
(const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame runtime-env none))
|
|
(assign-arguments runtime-frame none (vector-of object) phase)
|
|
(var result object)
|
|
(catch ((exec ((eval :block) (cons runtime-frame runtime-env) undefined))
|
|
(throw-error -syntax-error "a getter must return a value and may not return by falling off the end of its code"))
|
|
(x) (if (in x return :narrow-true)
|
|
(<- result (& value x))
|
|
(throw x)))
|
|
(return (coerce result (&opt return-type runtime-frame))))
|
|
|
|
((eval-static-set new-value runtime-env phase)
|
|
(note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "a constant expression cannot call setters"))
|
|
(const compile-frame parameter-frame (compile-frame :function-common 0))
|
|
(const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame runtime-env none))
|
|
(assign-arguments runtime-frame none (vector new-value) phase)
|
|
(catch ((exec ((eval :block) (cons runtime-frame runtime-env) undefined)))
|
|
(x) (rwhen (not-in x return)
|
|
(throw x))))
|
|
|
|
((eval-instance-call this args phase)
|
|
(note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "a constant expression cannot call user-defined functions"))
|
|
(note "Class frames are always preinstantiated, so the run environment is the same as compile environment.")
|
|
(const env environment (compile-env :function-common 0))
|
|
(const compile-frame parameter-frame (compile-frame :function-common 0))
|
|
(const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame env this))
|
|
(assign-arguments runtime-frame none args phase)
|
|
(var result object)
|
|
(catch ((exec ((eval :block) (cons runtime-frame env) undefined))
|
|
(<- result undefined))
|
|
(x) (if (in x return :narrow-true)
|
|
(<- result (& value x))
|
|
(throw x)))
|
|
(return (coerce result (&opt return-type runtime-frame))))
|
|
|
|
((eval-instance-get this phase)
|
|
(note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "a constant expression cannot call user-defined getters"))
|
|
(note "Class frames are always preinstantiated, so the run environment is the same as compile environment.")
|
|
(const env environment (compile-env :function-common 0))
|
|
(const compile-frame parameter-frame (compile-frame :function-common 0))
|
|
(const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame env this))
|
|
(assign-arguments runtime-frame none (vector-of object) phase)
|
|
(var result object)
|
|
(catch ((exec ((eval :block) (cons runtime-frame env) undefined))
|
|
(throw-error -syntax-error "a getter must return a value and may not return by falling off the end of its code"))
|
|
(x) (if (in x return :narrow-true)
|
|
(<- result (& value x))
|
|
(throw x)))
|
|
(return (coerce result (&opt return-type runtime-frame))))
|
|
|
|
((eval-instance-set this new-value phase)
|
|
(note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "a constant expression cannot call setters"))
|
|
(note "Class frames are always preinstantiated, so the run environment is the same as compile environment.")
|
|
(const env environment (compile-env :function-common 0))
|
|
(const compile-frame parameter-frame (compile-frame :function-common 0))
|
|
(const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame env this))
|
|
(assign-arguments runtime-frame none (vector new-value) phase)
|
|
(catch ((exec ((eval :block) (cons runtime-frame env) undefined)))
|
|
(x) (rwhen (not-in x return)
|
|
(throw x))))
|
|
|
|
((eval-instance-init this args phase)
|
|
(note "Class frames are always preinstantiated, so the run environment is the same as compile environment.")
|
|
(const env environment (compile-env :function-common 0))
|
|
(const compile-frame parameter-frame (compile-frame :function-common 0))
|
|
(const runtime-frame parameter-frame (instantiate-parameter-frame compile-frame env this))
|
|
(assign-arguments runtime-frame none args phase)
|
|
(when (not (& calls-superconstructor runtime-frame))
|
|
(const c class (assert-not-in (get-enclosing-class env) (tag none)))
|
|
(call-init this (& super c) (vector-of object) run)
|
|
(&= superconstructor-called runtime-frame true))
|
|
(catch ((exec ((eval :block) (cons runtime-frame env) undefined)))
|
|
(x) (rwhen (not-in x return)
|
|
(throw x)))
|
|
(rwhen (not (& superconstructor-called runtime-frame))
|
|
(throw-error -uninitialized-error "the superconstructor must be called before returning normally from a constructor")))
|
|
|
|
((eval-prototype-construct f args phase)
|
|
(note "The check that " (:expr boolean (not-in phase (tag compile))) " also ensures that " (:action setup) " has been called.")
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "a constant expression cannot call user-defined prototype constructors"))
|
|
(const runtime-env environment (assert-not-in (& env f) (tag none)))
|
|
(var archetype object (dot-read f (list-set (new qualified-name public "prototype")) phase))
|
|
(cond
|
|
((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)
|
|
(var result object)
|
|
(catch ((exec ((eval :block) (cons runtime-frame runtime-env) undefined))
|
|
(<- result undefined))
|
|
(x) (if (in x return :narrow-true)
|
|
(<- result (& value x))
|
|
(throw x)))
|
|
(const coerced-result object (coerce result (&opt return-type runtime-frame)))
|
|
(if (in coerced-result primitive-object)
|
|
(return o)
|
|
(return coerced-result)))
|
|
|
|
((validate-static-function cxt env kind)
|
|
((validate :function-common 0) cxt env kind normal)
|
|
(const length integer (parameter-count :parameters))
|
|
(case kind
|
|
(:select (tag plain-function)
|
|
(return (new uninstantiated-function -function length (eval-static-call :function-common 0) none (list-set-of simple-instance))))
|
|
(:select (tag unchecked-function prototype-function)
|
|
(return (new uninstantiated-function -prototype-function length (eval-static-call :function-common 0) (eval-prototype-construct :function-common 0)
|
|
(list-set-of simple-instance))))))))
|
|
|
|
(%print-actions ("Validation" overridden-property handling name plain compile-env compile-frame
|
|
validate validate-static validate-instance validate-constructor validate-static-function)
|
|
("Setup" setup setup-override)
|
|
("Evaluation" eval-static-call eval-static-get eval-static-set eval-instance-call eval-instance-get eval-instance-set eval-instance-init eval-prototype-construct))
|
|
|
|
|
|
(define (check-accessor-parameters (frame parameter-frame)) void
|
|
(const parameters (vector parameter) (&opt parameters frame))
|
|
(const rest variable-opt (&opt rest frame))
|
|
(case (& handling frame)
|
|
(:select (tag normal))
|
|
(:select (tag get)
|
|
(rwhen (or (nonempty parameters) (not-in rest (tag none)))
|
|
(throw-error -syntax-error "a getter cannot take any parameters")))
|
|
(:select (tag set)
|
|
(rwhen (or (/= (length parameters) 1) (not-in rest (tag none)))
|
|
(throw-error -syntax-error "a setter must take exactly one parameter"))
|
|
(rwhen (not-in (& default (nth parameters 0)) (tag none))
|
|
(throw-error -syntax-error "a setter" :apostrophe "s parameter cannot be optional")))))
|
|
|
|
|
|
(define (assign-arguments (runtime-frame parameter-frame) (f (union simple-instance (tag none))) (args (vector object)) (phase (tag run))) void
|
|
(// "This procedure performs a number of checks on the arguments, including checking their count, names, and values. "
|
|
"Although this procedure performs these checks in a specific order for expository purposes, an implementation may perform these checks in a different "
|
|
"order, which could have the effect of reporting a different error if there are multiple errors. "
|
|
"For example, if a function only allows between 2 and 4 arguments, the first of which must be a " (:character-literal "Number")
|
|
" and is passed five arguments the first of which is a " (:character-literal "String") ", then the implementation may throw an exception either about "
|
|
"the argument count mismatch or about the type coercion error in the first argument.")
|
|
(var arguments-object object-opt none)
|
|
(when (in (& kind runtime-frame) (tag unchecked-function))
|
|
(<- arguments-object (construct -array (vector-of object) phase))
|
|
(create-dynamic-property (assert-in arguments-object simple-instance) (new qualified-name public "callee") false false (assert-not-in f (tag none)))
|
|
(write-array-private-length (assert-not-in arguments-object (tag none)) (length args) phase))
|
|
(var rest-object object-opt none)
|
|
(const rest (union variable (tag none)) (&opt rest runtime-frame))
|
|
(when (not-in rest (tag none) :narrow-true)
|
|
(<- rest-object (construct -array (vector-of object) phase)))
|
|
(const parameters (vector parameter) (&opt parameters runtime-frame))
|
|
(var i integer 0)
|
|
(var j integer 0)
|
|
(for-each args arg
|
|
(cond
|
|
((< i (length parameters))
|
|
(const parameter parameter (nth parameters i))
|
|
(var default object-opt (& default parameter))
|
|
(var arg-or-default object arg)
|
|
(when (and (in arg-or-default (tag undefined)) (not-in default (tag none) :narrow-true))
|
|
(<- arg-or-default default))
|
|
(const v (union dynamic-var variable) (& var parameter))
|
|
(write-singleton-property v arg-or-default phase)
|
|
(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 (object-to-qualified-name (real-to-float64 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)
|
|
(rwhen (>= j array-limit)
|
|
(throw-error -range-error))
|
|
(index-write rest-object j arg phase)
|
|
(assert (in arguments-object (tag none))
|
|
(:assertion) " because a function can't have both a rest parameter and an " (:character-literal "arguments") " object.")
|
|
(<- j (+ j 1)))
|
|
((not-in arguments-object (tag none) :narrow-true)
|
|
(index-write arguments-object i arg phase))
|
|
(nil (throw-error -argument-error
|
|
"more arguments than parameters were supplied, and the called function does not have a " (:character-literal "...") " parameter and is not unchecked.")))
|
|
(<- i (+ i 1)))
|
|
(while (< i (length parameters))
|
|
(const parameter parameter (nth parameters i))
|
|
(var default object-opt (& default parameter))
|
|
(when (in default (tag none))
|
|
(if (not-in arguments-object (tag none))
|
|
(<- 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.")))
|
|
(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))
|
|
(setup-override (-> (environment parameter-frame parameter-frame) void)))
|
|
(production :parameters () parameters-none
|
|
(plain true)
|
|
(parameter-count 0)
|
|
((validate cxt env compile-frame) :forward)
|
|
((setup compile-env compile-frame) :forward)
|
|
((setup-override (compile-env :unused) (compile-frame :unused) overridden-signature)
|
|
(rwhen (or (nonempty (&opt parameters overridden-signature))
|
|
(not-in (&opt rest overridden-signature) (tag none)))
|
|
(throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))))
|
|
(production :parameters (:nonempty-parameters) parameters-nonempty
|
|
(plain (plain :nonempty-parameters))
|
|
(parameter-count (parameter-count :nonempty-parameters))
|
|
((validate cxt env compile-frame) :forward)
|
|
((setup compile-env compile-frame) :forward)
|
|
((setup-override compile-env compile-frame overridden-signature)
|
|
((setup-override :nonempty-parameters) compile-env compile-frame overridden-signature (&opt parameters overridden-signature)))))
|
|
|
|
|
|
(rule :nonempty-parameters ((plain boolean) (parameter-count integer)
|
|
(validate (-> (context environment parameter-frame) void))
|
|
(setup (-> (environment parameter-frame) void))
|
|
(setup-override (-> (environment parameter-frame parameter-frame (vector parameter)) void)))
|
|
(production :nonempty-parameters (:parameter-init) nonempty-parameters-parameter-init
|
|
(plain (plain :parameter-init))
|
|
(parameter-count 1)
|
|
((validate cxt env compile-frame) :forward)
|
|
((setup compile-env compile-frame)
|
|
((setup :parameter-init) compile-env compile-frame))
|
|
((setup-override compile-env compile-frame overridden-signature overridden-parameters)
|
|
(rwhen (empty overridden-parameters)
|
|
(throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))
|
|
((setup-override :parameter-init) compile-env compile-frame (nth overridden-parameters 0))
|
|
(rwhen (or (/= (length overridden-parameters) 1)
|
|
(not-in (&opt rest overridden-signature) (tag none)))
|
|
(throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))))
|
|
(production :nonempty-parameters (:parameter-init \, :nonempty-parameters) nonempty-parameters-parameter-init-and-more
|
|
(plain (and (plain :parameter-init) (plain :nonempty-parameters)))
|
|
(parameter-count (+ 1 (parameter-count :nonempty-parameters)))
|
|
((validate cxt env compile-frame) :forward)
|
|
((setup compile-env compile-frame)
|
|
((setup :parameter-init) compile-env compile-frame)
|
|
((setup :nonempty-parameters) compile-env compile-frame))
|
|
((setup-override compile-env compile-frame overridden-signature overridden-parameters)
|
|
(rwhen (empty overridden-parameters)
|
|
(throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))
|
|
((setup-override :parameter-init) compile-env compile-frame (nth overridden-parameters 0))
|
|
((setup-override :nonempty-parameters) compile-env compile-frame overridden-signature (subseq overridden-parameters 1))))
|
|
(production :nonempty-parameters (:rest-parameter) nonempty-parameters-rest-parameter
|
|
(plain false)
|
|
(parameter-count 0)
|
|
((validate cxt env compile-frame) :forward)
|
|
((setup (compile-env :unused) (compile-frame :unused)))
|
|
((setup-override (compile-env :unused) (compile-frame :unused) overridden-signature overridden-parameters)
|
|
(rwhen (nonempty overridden-parameters)
|
|
(throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))
|
|
(const overridden-rest (union variable (tag none)) (&opt rest overridden-signature))
|
|
(rwhen (or (in overridden-rest (tag none) :narrow-false) (/= (&opt type overridden-rest) -array class))
|
|
(throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature")))))
|
|
|
|
|
|
(rule :parameter ((name string)
|
|
(plain boolean)
|
|
(compile-var (writable-cell (union dynamic-var variable)))
|
|
(validate (-> (context environment (union parameter-frame local-frame)) void))
|
|
(setup (-> (environment (union parameter-frame local-frame) object-opt) void))
|
|
(setup-override (-> (environment parameter-frame object-opt parameter) void)))
|
|
(production :parameter (:parameter-attributes (:typed-identifier allow-in)) parameter-attributes-and-typed-identifier
|
|
(name (name :typed-identifier))
|
|
(plain (and (plain :typed-identifier) (not (has-const :parameter-attributes))))
|
|
((validate cxt env compile-frame)
|
|
((validate :typed-identifier) cxt env)
|
|
(const immutable boolean (has-const :parameter-attributes))
|
|
(const name string (name :typed-identifier))
|
|
(var v (union dynamic-var variable))
|
|
(cond
|
|
((and (in compile-frame parameter-frame :narrow-true) (in (& kind compile-frame) (tag unchecked-function)))
|
|
(assert (not immutable))
|
|
(<- v (define-hoisted-var env name undefined)))
|
|
(nil
|
|
(<- v (new variable :uninit none immutable none none :uninit))
|
|
(exec (define-singleton-property env name (list-set public) none false read-write v))))
|
|
(action<- (compile-var :parameter 0) v))
|
|
((setup compile-env compile-frame default)
|
|
(rwhen (and (in compile-frame parameter-frame :narrow-true)
|
|
(in default (tag none))
|
|
(some (&opt parameters compile-frame) p2 (not-in (& default p2) (tag none))))
|
|
(throw-error -syntax-error "a required parameter cannot follow an optional one"))
|
|
(const v (union dynamic-var variable) (compile-var :parameter 0))
|
|
(case v
|
|
(:select dynamic-var)
|
|
(:narrow variable
|
|
(var type class-opt ((setup-and-eval :typed-identifier) compile-env))
|
|
(when (in type (tag none))
|
|
(<- type -object))
|
|
(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)))))
|
|
((setup-override compile-env compile-frame default overridden-parameter)
|
|
(var new-default object-opt default)
|
|
(when (in new-default (tag none))
|
|
(<- new-default (& default overridden-parameter)))
|
|
(rwhen (and (in default (tag none)) (some (&opt parameters compile-frame) p2 (not-in (& default p2) (tag none))))
|
|
(throw-error -syntax-error "a required parameter cannot follow an optional one"))
|
|
(const v (union dynamic-var variable) (compile-var :parameter 0))
|
|
(assert (not-in v dynamic-var :narrow-true))
|
|
(var type class-opt ((setup-and-eval :typed-identifier) compile-env))
|
|
(when (in type (tag none))
|
|
(<- type -object))
|
|
(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 type)
|
|
(const p parameter (new parameter v new-default))
|
|
(&= parameters compile-frame (append (&opt parameters compile-frame) (vector p))))))
|
|
|
|
|
|
(rule :parameter-attributes ((has-const boolean))
|
|
(production :parameter-attributes () parameter-parameter-none
|
|
(has-const false))
|
|
(production :parameter-attributes (const) parameter-parameter-const
|
|
(has-const true)))
|
|
|
|
|
|
(rule :parameter-init ((plain boolean)
|
|
(validate (-> (context environment parameter-frame) void))
|
|
(setup (-> (environment parameter-frame) void))
|
|
(setup-override (-> (environment parameter-frame parameter) void)))
|
|
(production :parameter-init (:parameter) parameter-init-parameter
|
|
(plain (plain :parameter))
|
|
((validate cxt env compile-frame)
|
|
((validate :parameter) cxt env compile-frame))
|
|
((setup compile-env compile-frame)
|
|
((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-initializer
|
|
(plain false)
|
|
((validate cxt env compile-frame)
|
|
((validate :parameter) cxt env compile-frame)
|
|
((validate :assignment-expression) cxt env))
|
|
((setup compile-env compile-frame)
|
|
((setup :assignment-expression))
|
|
(const default object (read-reference ((eval :assignment-expression) compile-env compile) compile))
|
|
((setup :parameter) compile-env compile-frame default))
|
|
((setup-override compile-env compile-frame overridden-parameter)
|
|
((setup :assignment-expression))
|
|
(const default object (read-reference ((eval :assignment-expression) compile-env compile) compile))
|
|
((setup-override :parameter) compile-env compile-frame default overridden-parameter))))
|
|
|
|
|
|
(rule :rest-parameter ((validate (-> (context environment parameter-frame) void)))
|
|
(production :rest-parameter (\.\.\.) rest-parameter-none
|
|
((validate (cxt :unused) (env :unused) compile-frame)
|
|
(assert (not-in (& kind compile-frame) (tag unchecked-function)))
|
|
(const v variable (new variable -array none true none none :uninit))
|
|
(&= rest compile-frame v)))
|
|
(production :rest-parameter (\.\.\. :parameter-attributes :identifier) rest-parameter-parameter
|
|
((validate (cxt :unused) env compile-frame)
|
|
(assert (not-in (& kind compile-frame) (tag unchecked-function)))
|
|
(const v variable (new variable -array none (has-const :parameter-attributes) none none :uninit))
|
|
(&= rest compile-frame v)
|
|
(const name string (name :identifier))
|
|
(exec (define-singleton-property env name (list-set public) none false read-write v)))))
|
|
|
|
|
|
(rule :result ((plain boolean)
|
|
(validate (-> (context environment) void))
|
|
(setup (-> (environment parameter-frame) void))
|
|
(setup-override (-> (environment parameter-frame parameter-frame) void)))
|
|
(production :result () result-none
|
|
(plain true)
|
|
((validate cxt env) :forward)
|
|
((setup (compile-env :unused) compile-frame)
|
|
(var default-return-type class -object)
|
|
(when (cannot-return-value compile-frame)
|
|
(<- default-return-type -void))
|
|
(&const= return-type compile-frame default-return-type))
|
|
((setup-override (compile-env :unused) compile-frame overridden-signature)
|
|
(&const= return-type compile-frame (&opt return-type overridden-signature))))
|
|
(production :result (\: (:type-expression allow-in)) result-colon-and-type-expression
|
|
(plain false)
|
|
((validate cxt env) :forward)
|
|
((setup compile-env compile-frame)
|
|
(rwhen (cannot-return-value compile-frame)
|
|
(throw-error -syntax-error "a setter or constructor cannot define a return type"))
|
|
(&const= return-type compile-frame ((setup-and-eval :type-expression) compile-env)))
|
|
((setup-override compile-env compile-frame overridden-signature)
|
|
(const t class ((setup-and-eval :type-expression) compile-env))
|
|
(rwhen (/= (&opt return-type overridden-signature) t class)
|
|
(throw-error -definition-error "mismatch with the overridden method" :apostrophe "s signature"))
|
|
(&const= return-type compile-frame t)))
|
|
;(production :result ((:- {) (:type-expression allow-in)) result-type-expression)
|
|
)
|
|
(%print-actions ("Validation" name plain has-const parameter-count compile-var validate) ("Setup" setup setup-override))
|
|
|
|
|
|
(%heading 2 "Class Definition")
|
|
(rule :class-definition ((class (writable-cell class))
|
|
(validate (-> (context environment boolean attribute-opt-not-false) void))
|
|
(setup (-> () void))
|
|
(eval (-> (environment object) object)))
|
|
(production :class-definition (class :identifier :inheritance :block) class-definition-definition
|
|
((validate cxt env preinst attr)
|
|
(rwhen (not preinst)
|
|
(throw-error -syntax-error "a class may be defined only in a preinstantiated scope"))
|
|
(const super class ((validate :inheritance) cxt env))
|
|
(rwhen (not (& complete super))
|
|
(throw-error -constant-error "cannot override a class before its definition has been compiled"))
|
|
(rwhen (& final super)
|
|
(throw-error -definition-error "can" :apostrophe "t override a " (:character-literal "final") " class"))
|
|
(var a compound-attribute (to-compound-attribute attr))
|
|
(rwhen (& prototype a)
|
|
(throw-error -attribute-error "a class definition cannot have the " (:character-literal "prototype") " attribute"))
|
|
(var final boolean)
|
|
(case (& category a)
|
|
(:select (tag none) (<- final false))
|
|
(:select (tag static)
|
|
(rwhen (not-in (nth env 0) class)
|
|
(throw-error -attribute-error "non-class property definitions cannot have a " (:character-literal "static") " attribute"))
|
|
(<- final false))
|
|
(:select (tag final) (<- final true))
|
|
(:select (tag virtual) (throw-error -attribute-error "a class definition cannot have the " (:character-literal "virtual") " attribute")))
|
|
(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) (list-set-of instance-property) super (&opt prototype super) false
|
|
(name :identifier) "object" private-namespace dynamic final null hint-number
|
|
(& has-property super) (& bracket-read super) (& bracket-write super) (& bracket-delete super)
|
|
(& read super) (& write super) (& delete super)
|
|
(& enumerate super)
|
|
ordinary-call ordinary-construct none ordinary-is ordinary-coerce))
|
|
(action<- (class :class-definition 0) c)
|
|
(const v variable (new variable -class c true none none :uninit))
|
|
(exec (define-singleton-property env (name :identifier) (& namespaces a) (& override-mod a) (& explicit a) read-write v))
|
|
(const inner-cxt context (new context (& strict cxt) (set+ (& open-namespaces cxt) (list-set private-namespace))))
|
|
((validate-using-frame :block) inner-cxt env (new jump-targets (list-set-of label) (list-set-of label)) preinst c)
|
|
(when (in (& init c) (tag none))
|
|
(&= init c (& init super)))
|
|
(&= complete c true))
|
|
|
|
((setup)
|
|
((setup :block)))
|
|
|
|
((eval env d)
|
|
(const c class (class :class-definition 0))
|
|
(return ((eval-using-frame :block) env c d)))))
|
|
|
|
|
|
(rule :inheritance ((validate (-> (context environment) class)))
|
|
(production :inheritance () inheritance-none
|
|
((validate (cxt :unused) (env :unused)) (return -object)))
|
|
(production :inheritance (extends (:type-expression allow-in)) inheritance-extends
|
|
((validate cxt env)
|
|
((validate :type-expression) cxt env)
|
|
(return ((setup-and-eval :type-expression) env))))
|
|
#|(production :inheritance (implements :type-expression-list) inheritance-implements
|
|
((validate (cxt :unused) (env :unused)) (return -object)))
|
|
(production :inheritance (extends (:type-expression allow-in) implements :type-expression-list) inheritance-extends-implements
|
|
((validate (cxt :unused) (env :unused)) (return -object)))|#)
|
|
(%print-actions ("Validation" class validate) ("Setup" setup) ("Evaluation" eval))
|
|
|
|
|
|
;(%heading 2 "Interface Definition")
|
|
;(production (:interface-definition :omega_2) (interface :identifier :extends-list :block) interface-definition-definition)
|
|
;(production (:interface-definition :omega_2) (interface :identifier (:semicolon :omega_2)) interface-definition-declaration)
|
|
;***** Clear break and continue inside validate
|
|
|
|
;(production :extends-list () extends-list-none)
|
|
;(production :extends-list (extends :type-expression-list) extends-list-one)
|
|
|
|
;(production :type-expression-list ((:type-expression allow-in)) type-expression-list-one)
|
|
;(production :type-expression-list (:type-expression-list \, (:type-expression allow-in)) type-expression-list-more)
|
|
|
|
|
|
(%heading 2 "Namespace Definition")
|
|
(rule :namespace-definition ((validate (-> (context environment boolean attribute-opt-not-false) void)))
|
|
(production :namespace-definition (namespace :identifier) namespace-definition-normal
|
|
((validate (cxt :unused) env preinst attr)
|
|
(rwhen (not preinst)
|
|
(throw-error -syntax-error "a namespace may be defined only in a preinstantiated scope"))
|
|
(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)
|
|
(throw-error -attribute-error "a namespace definition cannot have the " (:character-literal "prototype") " attribute"))
|
|
(case (& category a)
|
|
(:select (tag none))
|
|
(:select (tag static)
|
|
(rwhen (not-in (nth env 0) class)
|
|
(throw-error -attribute-error "non-class property definitions cannot have a " (:character-literal "static") " attribute")))
|
|
(:select (tag virtual final)
|
|
(throw-error -attribute-error
|
|
"a namespace definition cannot have the " (:character-literal "virtual") " or " (:character-literal "final") " attribute")))
|
|
(const name string (name :identifier))
|
|
(const ns namespace (new namespace name))
|
|
(const v variable (new variable -namespace ns true none none :uninit))
|
|
(exec (define-singleton-property env name (& namespaces a) (& override-mod a) (& explicit a) read-write v)))))
|
|
(%print-actions ("Validation" validate))
|
|
|
|
|
|
(%heading 1 "Programs")
|
|
(rule :program ((process object))
|
|
(production :program (:directives) program-directives
|
|
(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)))))
|
|
(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
|
|
(std-explicit-const-binding (new qualified-name internal "internal") -namespace internal)
|
|
|
|
(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)
|
|
|
|
(std-const-binding (new qualified-name public "NaN") -number nan64)
|
|
(std-const-binding (new qualified-name public "Infinity") -number +infinity64)
|
|
(std-const-binding (new qualified-name public "fNaN") float nan32)
|
|
(std-const-binding (new qualified-name public "fInfinity") float +infinity32)
|
|
(std-const-binding (new qualified-name public "undefined") -void undefined)
|
|
|
|
(std-function (new qualified-name public "eval") global_eval 1)
|
|
(std-function (new qualified-name public "parseInt") global_parseInt 2)
|
|
(std-function (new qualified-name public "parseLong") global_parseLong 2)
|
|
(std-function (new qualified-name public "parseFloat") global_parseFloat 1)
|
|
(std-function (new qualified-name public "isNaN") global_isNaN 1)
|
|
(std-function (new qualified-name public "isFinite") global_isFinite 1)
|
|
(std-function (new qualified-name public "decodeURI") global_decodeURI 1)
|
|
(std-function (new qualified-name public "decodeURIComponent") global_decodeURIComponent 1)
|
|
(std-function (new qualified-name public "encodeURI") global_encodeURI 1)
|
|
(std-function (new qualified-name public "encodeURIComponent") global_encodeURIComponent 1)
|
|
|
|
(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 "char") -class char)
|
|
(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 "" none false internal)))
|
|
|
|
|
|
(%heading (2 :semantics) "Built-in Namespaces")
|
|
(define public namespace (new namespace "public"))
|
|
(define internal namespace (new namespace "internal"))
|
|
|
|
(%heading (2 :semantics) "Built-in Attributes")
|
|
(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 a constant expression.")
|
|
(var override-mod override-modifier)
|
|
(cond
|
|
((empty args) (<- override-mod true))
|
|
((= (length args) 1)
|
|
(const arg object (nth args 0))
|
|
(rwhen (not-in arg (tag true false undefined) :narrow-false)
|
|
(throw-error -type-error))
|
|
(<- override-mod arg))
|
|
(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")
|
|
|
|
(define (global_eval (this object :unused) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
|
|
(todo))
|
|
|
|
|
|
(define (global_parseInt (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
|
|
(note "This function can be used in a constant expression if the arguments can be converted to primitives in constant expressions.")
|
|
(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 (nth args 0) phase))
|
|
(var radix integer (object-to-integer (default-arg args 1 +zero64) phase))
|
|
(var i (union (exclude-zero integer) (tag +zero -zero nan)) (string-prefix-to-integer s radix))
|
|
(return (extended-rational-to-float64 i)))
|
|
|
|
(define (string-prefix-to-integer (s string) (radix integer))
|
|
(union (exclude-zero integer) (tag +zero -zero nan))
|
|
(var r integer radix)
|
|
(rwhen (set-not-in r (range-set-of-ranges integer 0 nil 2 36))
|
|
(throw-error -range-error "radix out of range"))
|
|
(var i integer 0)
|
|
(while (and (< i (length s))
|
|
(lisp-call white-space-or-line-terminator-char? ((nth s i))
|
|
boolean
|
|
"the nonterminal " (:grammar-symbol :white-space-or-line-terminator-char nil "lexer-semantics.html") " can expand into " (:expr string (vector (nth s i)))))
|
|
(<- i (+ i 1)))
|
|
(var sign (integer-list -1 1) 1)
|
|
(when (< i (length s))
|
|
(cond
|
|
((= (nth s i) #\+ char16)
|
|
(<- i (+ i 1)))
|
|
((= (nth s i) #\- char16)
|
|
(<- sign -1)
|
|
(<- i (+ i 1)))))
|
|
(when (and (set-in r (list-set 0 16))
|
|
(<= (+ i 2) (length s))
|
|
(set-in (subseq s i (+ i 1)) (list-set "0x" "0X")))
|
|
(<- r 16)
|
|
(<- i (+ i 2)))
|
|
(when (= r 0)
|
|
(<- r 10))
|
|
(var n integer 0)
|
|
(const start integer i)
|
|
(var digit integer-opt 0)
|
|
(while (and (< i (length s)) (not-in digit (tag none)))
|
|
(const ch char16 (nth s i))
|
|
(cond
|
|
((set-in ch (range-set-of-ranges char16 #\0 #\9))
|
|
(<- digit (- (char16-to-integer ch) (char16-to-integer #\0))))
|
|
((set-in ch (range-set-of-ranges char16 #\A #\Z))
|
|
(<- digit (+ (- (char16-to-integer ch) (char16-to-integer #\A)) 10)))
|
|
((set-in ch (range-set-of-ranges char16 #\a #\z))
|
|
(<- digit (+ (- (char16-to-integer ch) (char16-to-integer #\a)) 10)))
|
|
(nil (<- digit none)))
|
|
(when (and (not-in digit (tag none) :narrow-true) (>= digit r))
|
|
(<- digit none :end-narrow))
|
|
(when (not-in digit (tag none) :narrow-true)
|
|
(<- n (+ (* n r) digit))
|
|
(<- i (+ i 1))))
|
|
(rwhen (= i start)
|
|
(return nan))
|
|
(cond
|
|
((/= n 0) (return (* n sign)))
|
|
((> sign 0) (return +zero))
|
|
(nil (return -zero))))
|
|
|
|
(define (global_parseLong (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) general-number
|
|
(note "This function can be used in a constant expression if the arguments can be converted to primitives in constant expressions.")
|
|
(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 (nth args 0) phase))
|
|
(var radix integer (object-to-integer (default-arg args 1 +zero64) phase))
|
|
(var i (union (exclude-zero integer) (tag +zero -zero nan)) (string-prefix-to-integer s radix))
|
|
(case i
|
|
(:select (tag +zero -zero) (return (new long 0)))
|
|
(:narrow integer (return (integer-to-long i)))
|
|
(:select (tag nan) (return nan64))))
|
|
|
|
|
|
(define (global_parseFloat (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
|
|
(note "This function can be used in a constant expression if its argument can be converted to a primitive in a constant expression.")
|
|
(rwhen (/= (length args) 1)
|
|
(throw-error -argument-error "exactly one argument must be supplied"))
|
|
(const s string (object-to-string (nth args 0) phase))
|
|
(/* "Apply the lexer grammar with the start symbol " (:grammar-symbol :string-decimal-literal nil "lexer-semantics.html") " to the string " (:local s)
|
|
". If the grammar can interpret neither " (:local s) " nor any prefix of " (:local s) " as an expansion of "
|
|
(:grammar-symbol :string-decimal-literal nil "lexer-semantics.html") ", then " (:keyword return) :nbsp (:tag nan64)
|
|
". Otherwise, let " (:local p) " be the longest prefix of " (:local s) " (possibly " (:local s) " itself) such that " (:local p)
|
|
" is an expansion of " (:grammar-symbol :string-decimal-literal nil "lexer-semantics.html") ".")
|
|
(const q (union extended-rational (tag syntax-error))
|
|
(lisp-call string-prefix-to-float (s)
|
|
(union extended-rational (tag syntax-error))
|
|
"the result of lexing the longest possible prefix of " (:operand 0) " using " (:grammar-symbol :string-decimal-literal nil "lexer-semantics.html")
|
|
" as the start symbol"))
|
|
(rwhen (in q (tag syntax-error) :narrow-false)
|
|
(return nan64))
|
|
(*/)
|
|
(// (:local q) ":" :nbsp (:type extended-rational) " " :assign-10 " the value of the action " (:action lex) " applied to "
|
|
(:local p) :apostrophe "s expansion of the nonterminal " (:grammar-symbol :string-decimal-literal nil "lexer-semantics.html") ";")
|
|
(return (extended-rational-to-float64 q)))
|
|
|
|
|
|
(define (global_isNaN (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) \#boolean
|
|
(note "This function can be used in a constant expression if its argument can be converted to a primitive in a constant expression.")
|
|
(rwhen (/= (length args) 1)
|
|
(throw-error -argument-error "exactly one argument must be supplied"))
|
|
(const x general-number (object-to-general-number (nth args 0) phase))
|
|
(return (in x (tag nan32 nan64))))
|
|
|
|
|
|
(define (global_isFinite (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) \#boolean
|
|
(note "This function can be used in a constant expression if its argument can be converted to a primitive in a constant expression.")
|
|
(rwhen (/= (length args) 1)
|
|
(throw-error -argument-error "exactly one argument must be supplied"))
|
|
(const x general-number (object-to-general-number (nth args 0) phase))
|
|
(return (not-in x (tag nan32 nan64 +infinity32 +infinity64 -infinity32 -infinity64))))
|
|
|
|
|
|
(define (global_decodeURI (this object :unused) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
|
|
(todo))
|
|
|
|
|
|
(define (global_decodeURIComponent (this object :unused) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
|
|
(todo))
|
|
|
|
|
|
(define (global_encodeURI (this object :unused) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
|
|
(todo))
|
|
|
|
|
|
(define (global_encodeURIComponent (this object :unused) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) object
|
|
(todo))
|
|
|
|
|
|
|
|
(%heading (1 :semantics) "Built-in Classes")
|
|
(define (dummy-call (this object :unused) (c class :unused) (args (vector object) :unused) (phase phase :unused)) object
|
|
(todo))
|
|
(define (dummy-construct (c class :unused) (args (vector object) :unused) (phase phase :unused)) object
|
|
(todo))
|
|
|
|
|
|
(define prototypes-sealed boolean false)
|
|
|
|
|
|
(%heading (2 :semantics) "Object")
|
|
(define -object class
|
|
(new class
|
|
(list-set-of local-binding)
|
|
(list-set-of instance-property)
|
|
none (delay -object-prototype) true
|
|
"Object" "object" :uninit true false undefined hint-number
|
|
ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
call-object construct-object none ordinary-is coerce-object))
|
|
|
|
(define (call-object (this object :unused) (c class :unused) (args (vector object)) (phase phase :unused)) object
|
|
(note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
|
|
(cond
|
|
((= (length args) 0) (return undefined))
|
|
((= (length args) 1) (return (nth args 0)))
|
|
(nil (throw-error -argument-error "at most one argument can be supplied"))))
|
|
|
|
(define (construct-object (c class :unused) (args (vector object)) (phase phase :unused)) object
|
|
(note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
|
|
(rwhen (> (length args) 1)
|
|
(throw-error -argument-error "at most one argument can be supplied"))
|
|
(const o object (default-arg args 0 undefined))
|
|
(if (in o (tag null undefined))
|
|
(return (create-simple-instance -object -object-prototype none none none))
|
|
(return o)))
|
|
|
|
(define (coerce-object (o object) (c class :unused)) object-opt
|
|
(return o))
|
|
|
|
(define -object-prototype simple-instance
|
|
(new simple-instance
|
|
(%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))
|
|
|
|
|
|
(define (-object_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) string
|
|
(note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
|
|
(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 a constant expression"))
|
|
(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 a constant expression.")
|
|
(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)) \#boolean
|
|
(rwhen (in phase (tag compile))
|
|
(throw-error -constant-error (:character-literal "hasOwnProperty") " cannot be called from a constant expression"))
|
|
(rwhen (/= (length args) 1)
|
|
(throw-error -argument-error "exactly one argument must be supplied"))
|
|
(return (has-property this (nth args 0) true phase)))
|
|
|
|
|
|
(define (-object_is-prototype-of (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) \#boolean
|
|
(rwhen (in phase (tag compile))
|
|
(throw-error -constant-error (:character-literal "isPrototypeOf") " cannot be called from a constant expression"))
|
|
(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)) \#boolean
|
|
(rwhen (in phase (tag compile))
|
|
(throw-error -constant-error (:character-literal "propertyIsEnumerable") " cannot be called from a constant expression"))
|
|
(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)) undefined
|
|
(rwhen (in phase (tag compile))
|
|
(throw-error -constant-error (:character-literal "sealProperty") " cannot be called from a constant expression"))
|
|
(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))
|
|
(rwhen (not (has-property this arg true phase))
|
|
(throw-error -reference-error "property not found"))
|
|
(const qname qualified-name (object-to-qualified-name arg phase))
|
|
(seal-local-property this qname)))
|
|
(return undefined))
|
|
|
|
|
|
|
|
(%heading (2 :semantics) "Never")
|
|
(define -never class
|
|
(new class
|
|
(list-set-of local-binding) (list-set-of instance-property) -object none true
|
|
"Never" "" :uninit false true none :uninit
|
|
ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
same-as-construct construct-never none ordinary-is coerce-never))
|
|
|
|
(define (construct-never (c class :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 (coerce-never (o object :unused) (c class :unused)) (tag none)
|
|
(return none))
|
|
|
|
|
|
(%heading (2 :semantics) "Void")
|
|
(define -void class
|
|
(new class
|
|
(list-set-of local-binding) (list-set-of instance-property) -object none true
|
|
"Void" "undefined" :uninit false true undefined :uninit
|
|
ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
call-void construct-void none ordinary-is coerce-void))
|
|
|
|
(define (call-void (this object :unused) (c class :unused) (args (vector object)) (phase phase :unused)) undefined
|
|
(note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
|
|
(rwhen (> (length args) 1)
|
|
(throw-error -argument-error "at most one argument can be supplied"))
|
|
(return undefined))
|
|
|
|
(define (construct-void (c class :unused) (args (vector object)) (phase phase :unused)) undefined
|
|
(note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
|
|
(rwhen (/= (length args) 0)
|
|
(throw-error -argument-error "no arguments can be supplied"))
|
|
(return undefined))
|
|
|
|
(define (coerce-void (o object) (c class :unused)) (tag undefined none)
|
|
(if (in o (union null undefined))
|
|
(return undefined)
|
|
(return none)))
|
|
|
|
|
|
(%heading (2 :semantics) "Null")
|
|
(define -null class
|
|
(new class
|
|
(list-set-of local-binding) (list-set-of instance-property) -object none true
|
|
"Null" "object" :uninit false true null :uninit
|
|
ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
call-null construct-null none ordinary-is coerce-null))
|
|
|
|
(define (call-null (this object :unused) (c class :unused) (args (vector object)) (phase phase :unused)) null
|
|
(note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
|
|
(rwhen (> (length args) 1)
|
|
(throw-error -argument-error "at most one argument can be supplied"))
|
|
(return null))
|
|
|
|
(define (construct-null (c class :unused) (args (vector object)) (phase phase :unused)) null
|
|
(note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
|
|
(rwhen (/= (length args) 0)
|
|
(throw-error -argument-error "no arguments can be supplied"))
|
|
(return null))
|
|
|
|
(define (coerce-null (o object) (c class :unused)) (tag null none)
|
|
(if (in o (tag null) :narrow-true)
|
|
(return o)
|
|
(return none)))
|
|
|
|
|
|
(%heading (2 :semantics) "Boolean")
|
|
(define -boolean class
|
|
(new class
|
|
(list-set-of local-binding) (list-set-of instance-property) -object (delay -boolean-prototype) true
|
|
"Boolean" "boolean" :uninit false true false :uninit
|
|
ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
same-as-construct construct-boolean none ordinary-is coerce-boolean))
|
|
|
|
(define (construct-boolean (c class :unused) (args (vector object)) (phase phase :unused)) \#boolean
|
|
(note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
|
|
(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 (coerce-boolean (o object) (c class :unused)) boolean-opt
|
|
(if (in o boolean :narrow-true)
|
|
(return o)
|
|
(return none)))
|
|
|
|
(define -boolean-prototype simple-instance
|
|
(new simple-instance
|
|
(%list-set
|
|
(std-const-binding (new qualified-name public "constructor") -class -boolean)
|
|
(std-function (new qualified-name public "toString") -boolean_to-string 0)
|
|
(std-reserve (new qualified-name public "valueOf") -object-prototype))
|
|
-object-prototype prototypes-sealed -object
|
|
(list-set-of slot) none none none))
|
|
|
|
|
|
(define (-boolean_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
|
|
(note "This function can be used in a constant expression.")
|
|
(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) (list-set-of instance-property) -object (delay -general-number-prototype) true
|
|
"GeneralNumber" "object" :uninit false true nan64 hint-number
|
|
ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
same-as-construct construct-general-number none ordinary-is coerce-general-number))
|
|
|
|
(define (construct-general-number (c class :unused) (args (vector object)) (phase phase)) general-number
|
|
(note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
|
|
(cond
|
|
((= (length args) 0) (return +zero64))
|
|
((= (length args) 1) (return (object-to-general-number (nth args 0) phase)))
|
|
(nil (throw-error -argument-error "at most one argument can be supplied"))))
|
|
|
|
(define (coerce-general-number (o object) (c class :unused)) (union general-number (tag none))
|
|
(if (in o general-number :narrow-true)
|
|
(return o)
|
|
(return none)))
|
|
|
|
(define -general-number-prototype simple-instance
|
|
(new simple-instance
|
|
(%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-reserve (new qualified-name public "valueOf") -object-prototype)
|
|
(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))
|
|
|
|
|
|
(define (-general-number_to-string (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
|
|
(note "This function can be used in a constant expression 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 integer (object-to-integer (default-arg args 0 10.0) phase))
|
|
(rwhen (or (< 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)) string
|
|
(note "This function can be used in a constant expression 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 integer (object-to-integer (default-arg args 0 +zero64) phase))
|
|
(rwhen (or (< 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))
|
|
(cond
|
|
((= fraction-digits 0)
|
|
(return (append sign digits)))
|
|
(nil
|
|
(when (<= (length digits) fraction-digits)
|
|
(<- digits (append (repeat char16 #\0 (- (+ fraction-digits 1) (length digits))) digits)))
|
|
(const k integer (- (length digits) fraction-digits))
|
|
(return (append sign (subseq digits 0 (- k 1)) "." (subseq digits k))))))
|
|
|
|
|
|
(define (-general-number_to-exponential (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
|
|
(note "This function can be used in a constant expression 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-extended-integer (default-arg args 0 nan64) phase))
|
|
(rwhen (or (in fraction-digits (tag +infinity -infinity) :narrow-false) (and (not-in fraction-digits (tag nan) :narrow-true)
|
|
(or (< 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))
|
|
(var sign string "")
|
|
(when (< r 0 rational)
|
|
(<- sign "-")
|
|
(<- r (rat-neg r)))
|
|
(var digits string)
|
|
(var e integer)
|
|
(cond
|
|
((not-in fraction-digits (tag nan) :narrow-true)
|
|
(cond
|
|
((= r 0 rational)
|
|
(<- digits (repeat char16 #\0 (+ fraction-digits 1)))
|
|
(<- e 0))
|
|
(nil
|
|
(<- e (floor-log10 r))
|
|
(var n integer (floor (rat+ (rat* r (expt 10 (- fraction-digits e))) (rat/ 1 2))))
|
|
(assert (cascade rational (expt 10 fraction-digits) <= n <= (expt 10 (+ fraction-digits 1))) "At this point " (:assertion))
|
|
(when (= n (expt 10 (+ fraction-digits 1)) rational)
|
|
(<- n (int/ n 10))
|
|
(<- e (+ e 1)))
|
|
(<- digits (integer-to-string n))))
|
|
(assert (= (length digits) (+ fraction-digits 1)) "At this point the string " (:local digits) " has exactly " (:expr integer (+ fraction-digits 1)) " digits"))
|
|
((= r 0 rational)
|
|
(<- digits "0")
|
|
(<- e 0))
|
|
((in x (union long u-long) :narrow-false)
|
|
(<- digits (integer-to-string (assert-in r integer)))
|
|
(<- e (- (length digits) 1))
|
|
(while (= (nth digits (- (length digits) 1)) #\0 char16)
|
|
(<- digits (subseq digits 0 (- (length digits) 2)))))
|
|
(nil
|
|
(quiet-assert (not-in x (tag +zero32 -zero32 +zero64 -zero64) :narrow-true))
|
|
(var k integer)
|
|
(var s integer)
|
|
(case x
|
|
(:narrow nonzero-finite-float32
|
|
(/* (:initialize e) (:initialize k) (:initialize s)
|
|
"Let " (:local e) ", " (:local k) ", and " (:local s) " be integers such that "
|
|
(:expr boolean (>= k 1)) ", " (:expr boolean (cascade rational (expt 10 (- k 1)) <= s <= (expt 10 k))) ", "
|
|
(:expr boolean (= (real-to-float32 (rat* s (expt 10 (- (+ e 1) k)))) x float32)) ", and " (:local k) " is as small as possible.")
|
|
(multiple-value-bind ((digits2 string) (e2 integer)) decompose-positive-float32 ((if (< r 0 rational) (float32-negate x) x)))
|
|
(<- digits digits2)
|
|
(<- e e2)
|
|
(<- k (length digits))
|
|
(<- s k) ;Shut up unreference variable warnings
|
|
(<- k s)
|
|
(*/))
|
|
(:narrow nonzero-finite-float64
|
|
(/* (:initialize e) (:initialize k) (:initialize s)
|
|
"Let " (:local e) ", " (:local k) ", and " (:local s) " be integers such that "
|
|
(:expr boolean (>= k 1)) ", " (:expr boolean (cascade rational (expt 10 (- k 1)) <= s <= (expt 10 k))) ", "
|
|
(:expr boolean (= (real-to-float64 (rat* s (expt 10 (- (+ e 1) k)))) x float64)) ", and " (:local k) " is as small as possible.")
|
|
(multiple-value-bind ((digits2 string) (e2 integer)) decompose-positive-float64 ((if (< r 0 rational) (float64-negate x) x)))
|
|
(<- digits digits2)
|
|
(<- e e2)
|
|
(<- k (length digits))
|
|
(<- s k) ;Shut up unreference variable warnings
|
|
(<- k s)
|
|
(*/)))
|
|
(note (:local k) " is the number of digits in the decimal representation of " (:local s) ", " (:local s)
|
|
" is not divisible by 10, and the least significant digit of " (:local s)
|
|
" is not necessarily uniquely determined by the above criteria.")
|
|
(// "When there are multiple possibilities for " (:local s) " according to the rules above, "
|
|
"implementations are encouraged but not required to select the one according to the following rules: "
|
|
"Select the value of " (:local s) " for which " (:expr rational (rat* s (expt 10 (- (+ e 1) k)))) " is closest in value to " (:local r)
|
|
"; if there are two such possible values of " (:local s) ", choose the one that is even.")
|
|
(// (:local digits) :nbsp :assign-10 :nbsp (:expr string (integer-to-string s)))))
|
|
(return (append sign (exponential-notation-string digits e))))
|
|
|
|
|
|
(define (-general-number_to-precision (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
|
|
(note "This function can be used in a constant expression 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 precision extended-integer (object-to-extended-integer (default-arg args 0 nan64) phase))
|
|
(rwhen (in precision (tag nan) :narrow-false)
|
|
(return (general-number-to-string x)))
|
|
(rwhen (or (in precision (tag +infinity -infinity) :narrow-false) (< precision 1) (> precision (+ precision-limit 1)))
|
|
(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))
|
|
(var sign string "")
|
|
(when (< r 0 rational)
|
|
(<- sign "-")
|
|
(<- r (rat-neg r)))
|
|
(var digits string)
|
|
(var e integer)
|
|
(cond
|
|
((= r 0 rational)
|
|
(<- digits (repeat char16 #\0 precision))
|
|
(<- e 0))
|
|
(nil
|
|
(<- e (floor-log10 r))
|
|
(var n integer (floor (rat+ (rat* r (expt 10 (- (- precision 1) e))) (rat/ 1 2))))
|
|
(assert (cascade rational (expt 10 (- precision 1)) <= n <= (expt 10 precision)) "At this point " (:assertion))
|
|
(when (= n (expt 10 precision) rational)
|
|
(<- n (int/ n 10))
|
|
(<- e (+ e 1)))
|
|
(<- digits (integer-to-string n))))
|
|
(assert (= (length digits) precision) "At this point the string " (:local digits) " has exactly " (:local precision) " digits")
|
|
(cond
|
|
((or (< e -6) (>= e precision))
|
|
(return (append sign (exponential-notation-string digits e))))
|
|
((= e (- precision 1))
|
|
(return (append sign digits)))
|
|
((>= e 0)
|
|
(return (append sign (subseq digits 0 e) "." (subseq digits (+ e 1)))))
|
|
(nil
|
|
(return (append sign "0." (repeat char16 #\0 (neg (+ e 1))) digits)))))
|
|
|
|
|
|
(%heading (2 :semantics) "long")
|
|
(define \#long class
|
|
(new class
|
|
(%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-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
same-as-construct construct-long none ordinary-is coerce-long))
|
|
|
|
(define (construct-long (c class :unused) (args (vector object)) (phase phase)) long
|
|
(note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
|
|
(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-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 (coerce-long (o object) (c class :unused)) (union long (tag none))
|
|
(rwhen (not-in o general-number :narrow-false)
|
|
(return none))
|
|
(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)
|
|
(std-reserve (new qualified-name public "toString") -general-number-prototype)
|
|
(std-reserve (new qualified-name public "valueOf") -general-number-prototype))
|
|
-general-number-prototype prototypes-sealed -object
|
|
(list-set-of slot) none none none))
|
|
|
|
|
|
(%heading (2 :semantics) "ulong")
|
|
(define ulong class
|
|
(new class
|
|
(%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-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
same-as-construct construct-u-long none ordinary-is coerce-u-long))
|
|
|
|
(define (construct-u-long (c class :unused) (args (vector object)) (phase phase)) u-long
|
|
(note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
|
|
(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-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 (coerce-u-long (o object) (c class :unused)) (union u-long (tag none))
|
|
(rwhen (not-in o general-number :narrow-false)
|
|
(return none))
|
|
(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)
|
|
(std-reserve (new qualified-name public "toString") -general-number-prototype)
|
|
(std-reserve (new qualified-name public "valueOf") -general-number-prototype))
|
|
-general-number-prototype prototypes-sealed -object
|
|
(list-set-of slot) none none none))
|
|
|
|
|
|
(%heading (2 :semantics) "float")
|
|
(define float class
|
|
(new class
|
|
(%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-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
same-as-construct construct-float none ordinary-is coerce-float))
|
|
|
|
(define (construct-float (c class :unused) (args (vector object)) (phase phase)) float32
|
|
(note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
|
|
(cond
|
|
((= (length args) 0) (return +zero32))
|
|
((= (length args) 1) (return (object-to-float32 (nth args 0) phase)))
|
|
(nil (throw-error -argument-error "at most one argument can be supplied"))))
|
|
|
|
(define (coerce-float (o object) (c class :unused)) (union float32 (tag none))
|
|
(if (in o general-number :narrow-true)
|
|
(return (to-float32 o))
|
|
(return none)))
|
|
|
|
(define float-prototype simple-instance
|
|
(new simple-instance
|
|
(%list-set
|
|
(std-const-binding (new qualified-name public "constructor") -class float)
|
|
(std-reserve (new qualified-name public "toString") -general-number-prototype)
|
|
(std-reserve (new qualified-name public "valueOf") -general-number-prototype))
|
|
-general-number-prototype prototypes-sealed -object
|
|
(list-set-of slot) none none none))
|
|
|
|
|
|
(%heading (2 :semantics) "Number")
|
|
(define -number class
|
|
(new class
|
|
(%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-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
same-as-construct construct-number none ordinary-is coerce-number))
|
|
|
|
(define (construct-number (c class :unused) (args (vector object)) (phase phase)) float64
|
|
(note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
|
|
(cond
|
|
((= (length args) 0) (return +zero64))
|
|
((= (length args) 1) (return (object-to-float64 (nth args 0) phase)))
|
|
(nil (throw-error -argument-error "at most one argument can be supplied"))))
|
|
|
|
(define (coerce-number (o object) (c class :unused)) (union float64 (tag none))
|
|
(if (in o general-number :narrow-true)
|
|
(return (to-float64 o))
|
|
(return none)))
|
|
|
|
(define -number-prototype simple-instance
|
|
(new simple-instance
|
|
(%list-set
|
|
(std-const-binding (new qualified-name public "constructor") -class -number)
|
|
(std-reserve (new qualified-name public "toString") -general-number-prototype)
|
|
(std-reserve (new qualified-name public "valueOf") -general-number-prototype))
|
|
-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 (construct (c class :unused) (args (vector object)) (phase phase)) float64
|
|
(note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
|
|
(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 (is (o object) (c class :unused)) boolean
|
|
(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 (coerce (o object) (c class :unused)) (union float64 (tag none))
|
|
(rwhen (not-in o general-number :narrow-false)
|
|
(return none))
|
|
(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
|
|
(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
|
|
(& has-property -number) (& bracket-read -number) (& bracket-write -number) (& bracket-delete -number)
|
|
(& read -number) (& write -number) (& delete -number)
|
|
(& enumerate -number)
|
|
same-as-construct construct none is coerce)))
|
|
|
|
(define sbyte class (make-built-in-integer-class "sbyte" -128 127))
|
|
(define byte class (make-built-in-integer-class "byte" 0 255))
|
|
(define short class (make-built-in-integer-class "short" -32768 32767))
|
|
(define ushort class (make-built-in-integer-class "ushort" 0 65535))
|
|
(define int class (make-built-in-integer-class "int" -2147483648 2147483647))
|
|
(define uint class (make-built-in-integer-class "uint" 0 4294967295))
|
|
|
|
|
|
|
|
(%heading (2 :semantics) "char")
|
|
(define char class
|
|
(new class
|
|
(list-set (std-function (new qualified-name public "fromCharCode") char_from-char-code 1))
|
|
(list-set-of instance-property) -object (delay char-prototype) true
|
|
"char" "char" :uninit false true #?0000 :uninit
|
|
ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
same-as-construct construct-char none ordinary-is coerce-char))
|
|
|
|
(define (call-char (this object :unused) (c class :unused) (args (vector object)) (phase phase)) char16
|
|
(note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
|
|
(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-char (c class :unused) (args (vector object)) (phase phase)) char16
|
|
(note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
|
|
(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 (tag undefined)) (return #?0000))
|
|
((in arg char16 :narrow-true) (return arg))
|
|
(nil
|
|
(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 (coerce-char (o object) (c class :unused)) (union char16 (tag none))
|
|
(if (in o char16 :narrow-true)
|
|
(return o)
|
|
(return none)))
|
|
|
|
|
|
(define (char_from-char-code (this object :unused) (f simple-instance :unused) (args (vector object)) (phase phase)) object
|
|
(note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
|
|
(rwhen (/= (length args) 1)
|
|
(throw-error -argument-error "exactly one argument must be supplied"))
|
|
(const i integer (object-to-integer (nth args 0) phase))
|
|
(if (cascade integer 0 <= i <= (hex #xFFFF))
|
|
(return (integer-to-char16 i))
|
|
(throw-error -range-error "character code out of range")))
|
|
|
|
|
|
(define char-prototype simple-instance
|
|
(new simple-instance
|
|
(%list-set
|
|
(std-const-binding (new qualified-name public "constructor") -class char)
|
|
(std-reserve (new qualified-name public "toString") -string-prototype)
|
|
(std-reserve (new qualified-name public "valueOf") -string-prototype))
|
|
-string-prototype prototypes-sealed -object
|
|
(list-set-of slot) none none none))
|
|
|
|
|
|
|
|
(%heading (2 :semantics) "String")
|
|
(define -string class
|
|
(new class
|
|
(list-set (std-function (new qualified-name public "fromCharCode") -string_from-char-code 1))
|
|
(%list-set-of instance-property
|
|
(new instance-getter (list-set (new qualified-name public "length")) true false :uninit -string_length))
|
|
-object (delay -string-prototype) true
|
|
"String" "string" :uninit false true null :uninit
|
|
string-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete read-string ordinary-write ordinary-delete ordinary-enumerate
|
|
same-as-construct construct-string none ordinary-is coerce-string))
|
|
|
|
(define (string-has-property (o object) (c class) (property object) (flat boolean) (phase phase)) boolean
|
|
(assert (in o string :narrow-true) (:assertion) " because " (:global string-has-property) " is only called on instances of class " (:character-literal "String") ".")
|
|
(const qname qualified-name (object-to-qualified-name property phase))
|
|
(const i integer-opt (multiname-to-unsigned-integer (list-set qname)))
|
|
(cond
|
|
((not-in i (tag none) :narrow-true)
|
|
(return (< i (length o))))
|
|
(nil
|
|
(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)))))))
|
|
|
|
(define (read-string (o object) (limit class) (multiname multiname) (env environment-opt) (undefined-if-missing boolean) (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-unsigned-integer multiname))
|
|
(when (not-in i (tag none) :narrow-true)
|
|
(cond
|
|
((< i (length o)) (return (nth o i)))
|
|
(undefined-if-missing (return undefined))
|
|
(nil (return none)))))
|
|
(return (ordinary-read o limit multiname env undefined-if-missing phase)))
|
|
|
|
(define (construct-string (c class :unused) (args (vector object)) (phase phase)) string
|
|
(note "This function can be used in a constant expression if the argument can be converted to a primitive in a constant expression.")
|
|
(cond
|
|
((= (length args) 0) (return ""))
|
|
((= (length args) 1) (return (object-to-string (nth args 0) phase)))
|
|
(nil (throw-error -argument-error "at most one argument can be supplied"))))
|
|
|
|
(define (coerce-string (o object) (c class :unused)) (union string null (tag none))
|
|
(cond
|
|
((in o (union null string) :narrow-true) (return o))
|
|
((in o char16 :narrow-true)
|
|
(return (vector o)))
|
|
(nil (return none))))
|
|
|
|
|
|
(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 a constant expression if the arguments can be converted to primitives in constant expressions.")
|
|
(var s string "")
|
|
(for-each args arg
|
|
(const i integer (object-to-integer arg phase))
|
|
(if (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
|
|
(std-const-binding (new qualified-name public "constructor") -class -string)
|
|
(std-function (new qualified-name public "toString") -string_to-string 0)
|
|
(std-reserve (new qualified-name public "valueOf") -object-prototype)
|
|
(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))
|
|
|
|
|
|
(define (-string_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
|
|
(note "This function can be used in a constant expression if " (:local this) " can be converted to a primitive in a constant expression.")
|
|
(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)) string
|
|
(note "This function can be used in a constant expression 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-extended-integer (default-arg args 0 +zero64) phase))
|
|
(cond
|
|
((in position (tag nan) :narrow-false) (throw-error -range-error))
|
|
((and (not-in position (tag +infinity -infinity) :narrow-true) (cascade integer 0 <= position < (length s)))
|
|
(return (vector (nth s position))))
|
|
(nil (return ""))))
|
|
|
|
|
|
(define (-string_char-code-at (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
|
|
(note "This function can be used in a constant expression 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-extended-integer (default-arg args 0 +zero64) phase))
|
|
(cond
|
|
((in position (tag nan) :narrow-false) (throw-error -range-error))
|
|
((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)))))
|
|
(nil (return nan64))))
|
|
|
|
|
|
(define (-string_concat (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
|
|
(note "This function can be used in a constant expression 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)) float64
|
|
(note "This function can be used in a constant expression 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))
|
|
(const arg object (default-arg args 1 +zero64))
|
|
(var position integer (pin-extended-integer (object-to-extended-integer arg phase) (length s) false))
|
|
(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)) float64
|
|
(note "This function can be used in a constant expression 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))
|
|
(const arg object (default-arg args 1 +infinity64))
|
|
(var position integer (pin-extended-integer (object-to-extended-integer arg phase) (length s) false))
|
|
(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)) float64
|
|
(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 a constant expression"))
|
|
(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 strings 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, they 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 float64)
|
|
(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 a constant expression"))
|
|
(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 a constant expression"))
|
|
(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 a constant expression"))
|
|
(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)) string
|
|
(note "This function can be used in a constant expression 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))
|
|
(const start-arg object (default-arg args 0 +zero64))
|
|
(const end-arg object (default-arg args 1 +infinity64))
|
|
(const start integer (pin-extended-integer (object-to-extended-integer start-arg phase) (length s) true))
|
|
(const end integer (pin-extended-integer (object-to-extended-integer end-arg phase) (length s) 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 a constant expression"))
|
|
(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)) string
|
|
(note "This function can be used in a constant expression 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))
|
|
(const start-arg object (default-arg args 0 +zero64))
|
|
(const end-arg object (default-arg args 1 +infinity64))
|
|
(const start integer (pin-extended-integer (object-to-extended-integer start-arg phase) (length s) false))
|
|
(const end integer (pin-extended-integer (object-to-extended-integer end-arg phase) (length s) false))
|
|
(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)) string
|
|
(note "This function can be used in a constant expression if " (:local this) " can be converted to a primitive in a constant expression.")
|
|
(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))
|
|
(const s32 (vector char21) (string-to-u-t-f32 s))
|
|
(var r string "")
|
|
(for-each s32 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)) string
|
|
(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 a constant expression"))
|
|
(const s string (object-to-string this phase))
|
|
(const s32 (vector char21) (string-to-u-t-f32 s))
|
|
(var r string "")
|
|
(for-each s32 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)) string
|
|
(note "This function can be used in a constant expression if " (:local this) " can be converted to a primitive in a constant expression.")
|
|
(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))
|
|
(const s32 (vector char21) (string-to-u-t-f32 s))
|
|
(var r string "")
|
|
(for-each s32 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)) string
|
|
(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 a constant expression"))
|
|
(const s string (object-to-string this phase))
|
|
(const s32 (vector char21) (string-to-u-t-f32 s))
|
|
(var r string "")
|
|
(for-each s32 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)
|
|
(%list-set-of instance-property
|
|
(new instance-variable (list-set (new qualified-name array-private "length")) true false -number +zero64 false)
|
|
(new instance-getter (list-set (new qualified-name public "length")) true false :uninit -array_get-length)
|
|
(new instance-setter (list-set (new qualified-name public "length")) true false :uninit -array_set-length))
|
|
-object (delay -array-prototype) true
|
|
"Array" "object" array-private true true null hint-number
|
|
ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read write-array ordinary-delete ordinary-enumerate
|
|
same-as-construct ordinary-construct init-array ordinary-is ordinary-coerce))
|
|
|
|
(define array-limit integer (/*/ (expt 2 53) "an implementation-defined integer value between " (:expr integer (- (expt 2 32) 1)) " and "
|
|
(:expr integer (expt 2 53)) " inclusive"))
|
|
(define array-private namespace (new namespace "private"))
|
|
|
|
(define (write-array (o object) (limit class) (multiname multiname) (env environment-opt) (new-value object) (create-if-missing boolean) (phase (tag run)))
|
|
(tag none ok)
|
|
(const result (tag none ok) (ordinary-write o limit multiname env new-value create-if-missing phase))
|
|
(when (in result (tag ok))
|
|
(const i integer-opt (multiname-to-unsigned-integer multiname))
|
|
(when (not-in i (tag none) :narrow-true)
|
|
(rwhen (>= i array-limit)
|
|
(throw-error -range-error "array index out of range"))
|
|
(var length integer (read-array-private-length o phase))
|
|
(when (>= i length)
|
|
(<- length (+ i 1))
|
|
(write-array-private-length o length phase))))
|
|
(return result))
|
|
|
|
(%text :comment (:global-call read-array-private-length array phase) " returns an " (:character-literal "Array") :apostrophe
|
|
"s private length. See also " (:global read-length) ", which can work on non-" (:character-literal "Array") " objects.")
|
|
(define (read-array-private-length (array object) (phase phase)) integer
|
|
(const length float64 (assert-in (read-instance-slot array (new qualified-name array-private "length") phase) float64))
|
|
(assert (not-in length (tag nan64 +infinity64 -infinity64) :narrow-true))
|
|
(var n rational (to-rational length))
|
|
(assert (and (in n integer :narrow-true) (cascade integer 0 <= n <= array-limit)))
|
|
(return n))
|
|
|
|
(%text :comment (:global-call write-array-private-length array length phase) " sets an " (:character-literal "Array") :apostrophe
|
|
"s private length to " (:local length) " after ensuring that " (:local length) " is between 0 and " (:global array-limit)
|
|
" inclusive. See also " (:global write-length) ", which can work on non-" (:character-literal "Array") " objects.")
|
|
(define (write-array-private-length (array object) (length integer) (phase (tag run))) void
|
|
(rwhen (or (< length 0) (> length array-limit))
|
|
(throw-error -range-error "array length out of range"))
|
|
(dot-write array (list-set (new qualified-name array-private "length")) (real-to-float64 length) phase))
|
|
|
|
(define (multiname-to-unsigned-integer (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))))
|
|
(return (assert-in (string-to-extended-integer name) integer)))))
|
|
(return none))
|
|
|
|
(define (init-array (this simple-instance) (args (vector object)) (phase (tag run))) void
|
|
(when (= (length args) 1)
|
|
(const arg object (nth args 0))
|
|
(rwhen (in arg general-number :narrow-true)
|
|
(const length integer-opt (check-integer arg))
|
|
(rwhen (in length (tag none) :narrow-false)
|
|
(throw-error -range-error "array length must be an integer"))
|
|
(write-array-private-length this length phase)
|
|
(return)))
|
|
(var i integer 0)
|
|
(for-each args arg
|
|
(index-write this i arg phase)
|
|
(<- i (+ i 1)))
|
|
(note "The call to " (:global index-write) " above also set the array" :apostrophe "s length to " (:local i) "."))
|
|
|
|
|
|
(define (-array_get-length (this object) (phase phase)) float64
|
|
(assert (is this -array) (:assertion) " because this getter cannot be extracted from the " (:character-literal "Array") " class.")
|
|
(note "An array" :apostrophe "s length is mutable, so reading it will throw " (:global -constant-error) " when " (:expr boolean (in phase (tag compile))) ".")
|
|
(return (assert-in (read-instance-slot this (new qualified-name array-private "length") phase) float64)))
|
|
|
|
(define (-array_set-length (this object) (length object) (phase phase)) void
|
|
(assert (is this -array) (:assertion) " because this setter cannot be extracted from the " (:character-literal "Array") " class.")
|
|
(quiet-assert (in this simple-instance :narrow-true))
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error "an array" :apostrophe "s " (:character-literal "length") " cannot be set from a constant expression"))
|
|
(const new-length integer-opt (check-integer (object-to-general-number length phase)))
|
|
(rwhen (or (in new-length (tag none) :narrow-false) (< new-length 0) (> new-length array-limit))
|
|
(throw-error -range-error "array length out of range or not an integer"))
|
|
(const old-length integer (read-array-private-length this phase))
|
|
(when (< new-length old-length)
|
|
(note "Delete all indexed properties greater than or equal to the new length")
|
|
(function (qname-in-deleted-range (qname qualified-name)) boolean
|
|
(const i integer-opt (multiname-to-unsigned-integer (list-set qname)))
|
|
(return (and (not-in i (tag none) :narrow-true) (cascade integer new-length <= i < old-length))))
|
|
(&= local-bindings this
|
|
(map (& local-bindings this)
|
|
b b (not (qname-in-deleted-range (& qname b))))))
|
|
(write-array-private-length this new-length phase))
|
|
|
|
|
|
(define -array-prototype simple-instance
|
|
(new simple-instance
|
|
(%list-set
|
|
(std-const-binding (new qualified-name public "constructor") -class -array)
|
|
(std-function (new qualified-name public "toString") -array_to-string 0)
|
|
(std-function (new qualified-name public "toLocaleString") -array_to-locale-string 0)
|
|
(std-function (new qualified-name public "concat") -array_concat 1)
|
|
(std-function (new qualified-name public "join") -array_join 1)
|
|
(std-function (new qualified-name public "pop") -array_pop 0)
|
|
(std-function (new qualified-name public "push") -array_push 1)
|
|
(std-function (new qualified-name public "reverse") -array_reverse 0)
|
|
(std-function (new qualified-name public "shift") -array_shift 0)
|
|
(std-function (new qualified-name public "slice") -array_slice 2)
|
|
(std-function (new qualified-name public "sort") -array_sort 1)
|
|
(std-function (new qualified-name public "splice") -array_splice 2)
|
|
(std-function (new qualified-name public "unshift") -array_unshift 1))
|
|
-object-prototype prototypes-sealed -object
|
|
(list-set-of slot) none none none))
|
|
;***** Add some properties here
|
|
|
|
|
|
(define (-array_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "toString") " cannot be called on an " (:character-literal "Array") " from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(note "This function ignores any arguments passed to it in " (:local args) ".")
|
|
(return (internal-join this "," phase)))
|
|
|
|
|
|
(define (-array_to-locale-string (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "toLocaleString") " cannot be called on an " (:character-literal "Array") " from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(note "This function passes any arguments passed to it in " (:local args) " to " (:character-literal "toLocaleString") " applied to the elements of the array.")
|
|
(const separator string (/*/ "," "the list-separator string appropriate for the host" :apostrophe "s current locale, derived in an implementation-defined way"))
|
|
(const length integer (read-length this phase))
|
|
(var result string "")
|
|
(var i integer 0)
|
|
(while (/= i length)
|
|
(const elt object-opt (index-read this i phase))
|
|
(when (not-in elt (tag undefined null none) :narrow-true)
|
|
(const to-locale-string-method object (dot-read elt (list-set (new qualified-name public "toLocaleString")) phase))
|
|
(const s object (call elt to-locale-string-method args phase))
|
|
(rwhen (not-in s (union char16 string) :narrow-false)
|
|
(throw-error -type-error (:character-literal "toLocaleString") " should return a string"))
|
|
(<- result (append result (to-string s))))
|
|
(<- i (+ i 1))
|
|
(when (/= i length)
|
|
(<- result (append result separator))))
|
|
(return result))
|
|
|
|
|
|
(define (-array_concat (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "concat") " cannot be called from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(const constituents (vector object) (append (vector this) args))
|
|
(const array object (construct -array (vector-of object) phase))
|
|
(var i integer 0)
|
|
(for-each constituents o
|
|
(cond
|
|
((is o -array)
|
|
(const o-length integer (read-length o phase))
|
|
(var k integer 0)
|
|
(while (/= k o-length)
|
|
(const elt object-opt (index-read o k phase))
|
|
(when (not-in elt (tag none) :narrow-true)
|
|
(index-write array i elt phase))
|
|
(<- k (+ k 1))
|
|
(<- i (+ i 1))))
|
|
(nil
|
|
(index-write array i o phase)
|
|
(<- i (+ i 1)))))
|
|
(write-array-private-length array i phase)
|
|
(return array))
|
|
|
|
|
|
(define (-array_join (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) string
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "join") " cannot be called from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(rwhen (> (length args) 1)
|
|
(throw-error -argument-error "at most one argument can be supplied"))
|
|
(const arg object (default-arg args 0 undefined))
|
|
(var separator string ",")
|
|
(when (not-in arg (tag undefined))
|
|
(<- separator (object-to-string arg phase)))
|
|
(return (internal-join this separator phase)))
|
|
|
|
|
|
(define (internal-join (this object) (separator string) (phase (tag run))) string
|
|
(const length integer (read-length this phase))
|
|
(var result string "")
|
|
(var i integer 0)
|
|
(while (/= i length)
|
|
(const elt object-opt (index-read this i phase))
|
|
(when (not-in elt (tag undefined null none) :narrow-true)
|
|
(<- result (append result (object-to-string elt phase))))
|
|
(<- i (+ i 1))
|
|
(when (/= i length)
|
|
(<- result (append result separator))))
|
|
(return result))
|
|
|
|
|
|
(define (-array_pop (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "pop") " cannot be called from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(rwhen (/= (length args) 0)
|
|
(throw-error -argument-error "no arguments can be supplied"))
|
|
(var length integer (read-length this phase))
|
|
(var result object undefined)
|
|
(when (/= length 0)
|
|
(<- length (- length 1))
|
|
(const elt object-opt (index-read this length phase))
|
|
(when (not-in elt (tag none) :narrow-true)
|
|
(<- result elt)
|
|
(index-write this length none phase)))
|
|
(write-length this length phase)
|
|
(return result))
|
|
|
|
|
|
(define (-array_push (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "push") " cannot be called from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(var length integer (read-length this phase))
|
|
(for-each args arg
|
|
(index-write this length arg phase)
|
|
(<- length (+ length 1)))
|
|
(write-length this length phase)
|
|
(return (real-to-float64 length)))
|
|
|
|
|
|
(define (-array_reverse (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "reverse") " cannot be called from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(rwhen (/= (length args) 0)
|
|
(throw-error -argument-error "no arguments can be supplied"))
|
|
(const length integer (read-length this phase))
|
|
(var lo integer 0)
|
|
(var hi integer (- length 1))
|
|
(while (< lo hi)
|
|
(const lo-elt object-opt (index-read this lo phase))
|
|
(const hi-elt object-opt (index-read this hi phase))
|
|
(index-write this lo hi-elt phase)
|
|
(index-write this hi lo-elt phase)
|
|
(<- lo (+ lo 1))
|
|
(<- hi (- hi 1)))
|
|
(return this))
|
|
|
|
|
|
(define (-array_shift (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "shift") " cannot be called from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(rwhen (/= (length args) 0)
|
|
(throw-error -argument-error "no arguments can be supplied"))
|
|
(var length integer (read-length this phase))
|
|
(var result object undefined)
|
|
(when (/= length 0)
|
|
(var elt object-opt (index-read this 0 phase))
|
|
(when (not-in elt (tag none) :narrow-true)
|
|
(<- result elt))
|
|
(var i integer 1)
|
|
(while (/= i length)
|
|
(<- elt (index-read this i phase))
|
|
(index-write this (- i 1) elt phase)
|
|
(<- i (+ i 1)))
|
|
(<- length (- length 1))
|
|
(index-write this length none phase))
|
|
(write-length this length phase)
|
|
(return result))
|
|
|
|
|
|
(define (-array_slice (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "slice") " cannot be called on an " (:character-literal "Array") " from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(rwhen (> (length args) 2)
|
|
(throw-error -argument-error "at most two arguments can be supplied"))
|
|
(const length integer (read-length this phase))
|
|
(const start-arg object (default-arg args 0 +zero64))
|
|
(const end-arg object (default-arg args 1 +infinity64))
|
|
(const start integer (pin-extended-integer (object-to-extended-integer start-arg phase) length true))
|
|
(const end integer (pin-extended-integer (object-to-extended-integer end-arg phase) length true))
|
|
(return (make-array-slice this start end phase)))
|
|
|
|
(define (make-array-slice (array object) (start integer) (end integer) (phase (tag run))) object
|
|
(const slice object (construct -array (vector-of object) phase))
|
|
(var i integer start)
|
|
(var j integer 0)
|
|
(while (< i end)
|
|
(const elt object-opt (index-read array i phase))
|
|
(index-write slice j elt phase)
|
|
(<- i (+ i 1))
|
|
(<- j (+ j 1)))
|
|
(write-length slice j phase)
|
|
(return slice))
|
|
|
|
|
|
(define (-array_sort (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "sort") " cannot be called from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(rwhen (> (length args) 1)
|
|
(throw-error -argument-error "at most one argument can be supplied"))
|
|
(todo))
|
|
|
|
|
|
(define (-array_splice (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) object
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "splice") " cannot be called from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(rwhen (< (length args) 2)
|
|
(throw-error -argument-error "at least two arguments must be supplied"))
|
|
(const length integer (read-length this phase))
|
|
(const start-arg object (default-arg args 0 +zero64))
|
|
(const delete-count-arg object (default-arg args 1 +zero64))
|
|
(const start integer (pin-extended-integer (object-to-extended-integer start-arg phase) length true))
|
|
(const delete-count integer (pin-extended-integer (object-to-extended-integer delete-count-arg phase) (- length start) false))
|
|
(const deleted-slice object (make-array-slice this start (+ start delete-count) phase))
|
|
(const new-elts (vector object) (subseq args 2))
|
|
(const new-elt-count integer (length new-elts))
|
|
(const count-diff integer (- new-elt-count delete-count))
|
|
(var i integer)
|
|
(cond
|
|
((< count-diff 0)
|
|
(<- i (+ start delete-count))
|
|
(while (/= i length)
|
|
(const elt object-opt (index-read this i phase))
|
|
(index-write this (+ i count-diff) elt phase)
|
|
(<- i (+ i 1)))
|
|
(<- i 0)
|
|
(while (/= i count-diff)
|
|
(<- i (- i 1))
|
|
(index-write this (+ length i) none phase)))
|
|
((> count-diff 0)
|
|
(<- i length)
|
|
(while (/= i (+ start delete-count))
|
|
(<- i (- i 1))
|
|
(const elt object-opt (index-read this i phase))
|
|
(index-write this (+ i count-diff) elt phase))))
|
|
(write-length this (+ length count-diff) phase)
|
|
(<- i start)
|
|
(for-each new-elts arg
|
|
(index-write this i arg phase)
|
|
(<- i (+ i 1)))
|
|
(return deleted-slice))
|
|
|
|
|
|
(define (-array_unshift (this object) (f simple-instance :unused) (args (vector object)) (phase phase)) float64
|
|
(rwhen (in phase (tag compile) :narrow-false)
|
|
(throw-error -constant-error (:character-literal "unshift") " cannot be called from a constant expression"))
|
|
(note "This function is generic and can be applied even if " (:local this) " is not an " (:character-literal "Array") ".")
|
|
(var i integer (read-length this phase))
|
|
(const n-args integer (length args))
|
|
(const new-length integer (+ n-args i))
|
|
(when (= n-args 0)
|
|
(// "At the implementation" :apostrophe "s discretion, either do nothing or " (:keyword return) :nbsp (:expr float64 (real-to-float64 new-length))))
|
|
(write-length this new-length phase)
|
|
(while (/= i 0)
|
|
(<- i (- i 1))
|
|
(const elt object-opt (index-read this i phase))
|
|
(index-write this (+ i n-args) elt phase))
|
|
(for-each args arg
|
|
(index-write this i arg phase)
|
|
(<- i (+ i 1)))
|
|
(return (real-to-float64 new-length)))
|
|
|
|
|
|
|
|
(%heading (2 :semantics) "Namespace")
|
|
(define -namespace class
|
|
(new class
|
|
(list-set-of local-binding) (list-set-of instance-property) -object (delay -namespace-prototype) true
|
|
"Namespace" "namespace" :uninit false true null hint-string
|
|
ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
ordinary-call construct-namespace none ordinary-is ordinary-coerce))
|
|
|
|
(define (construct-namespace (c class :unused) (args (vector object)) (phase phase)) namespace
|
|
(note "This function can be used in a constant expression 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 "a constant expression cannot construct new anonymous namespaces"))
|
|
(return (new namespace "anonymous")))
|
|
((in arg (union char16 string) :narrow-true)
|
|
(const name string (to-string arg))
|
|
(reserve ns)
|
|
(cond
|
|
((= name "" string)
|
|
(return public))
|
|
((some named-namespaces ns (= (& name ns) name string) :define-true)
|
|
(return ns))
|
|
(nil
|
|
(const ns2 namespace (new namespace name))
|
|
(<- named-namespaces (set+ named-namespaces (list-set ns2)))
|
|
(return ns2))))
|
|
(nil (throw-error -type-error))))
|
|
|
|
(defvar named-namespaces (list-set namespace) (list-set-of namespace))
|
|
|
|
(define -namespace-prototype simple-instance
|
|
(new simple-instance
|
|
(%list-set
|
|
(std-function (new qualified-name public "toString") -namespace_to-string 0)
|
|
(std-reserve (new qualified-name public "valueOf") -object-prototype))
|
|
-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 :unused)) string
|
|
(note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
|
|
(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) (list-set-of instance-property) -object (delay -object-prototype) true
|
|
"Attribute" "object" :uninit false true null hint-string
|
|
ordinary-has-property 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-coerce))
|
|
|
|
|
|
(%heading (2 :semantics) "Date")
|
|
(define -date class
|
|
(new class
|
|
(list-set-of local-binding) (list-set-of instance-property) -object (delay -date-prototype) true
|
|
"Date" "object" :uninit true true null hint-string
|
|
ordinary-has-property 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-coerce))
|
|
|
|
(define -date-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) "RegExp")
|
|
(define -reg-exp class
|
|
(new class
|
|
(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-has-property 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-coerce))
|
|
|
|
(define -reg-exp-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) "Class")
|
|
(define -class class
|
|
(new class
|
|
(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-has-property 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-coerce))
|
|
|
|
(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
|
|
(std-const-binding (new qualified-name public "constructor") -class -class)
|
|
(std-function (new qualified-name public "toString") -class_to-string 0)
|
|
(std-reserve (new qualified-name public "valueOf") -object-prototype)
|
|
(std-const-binding (new qualified-name public "length") -number 1.0))
|
|
-object-prototype prototypes-sealed -object
|
|
(list-set-of slot) none none none))
|
|
|
|
|
|
(define (-class_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase :unused)) string
|
|
(note "This function does not check " (:local phase) " and therefore can be used in a constant expression.")
|
|
(note "This function ignores any arguments passed to it in " (:local args) ".")
|
|
(const c class (object-to-class this))
|
|
(return (append "[class " (& name c) "]")))
|
|
|
|
|
|
(%heading (2 :semantics) "Function")
|
|
(define -function class
|
|
(new class
|
|
(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-has-property 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-coerce))
|
|
|
|
(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
|
|
(list-set-of local-binding)
|
|
-object-prototype prototypes-sealed -object
|
|
(list-set-of slot) none none none))
|
|
;***** Add some properties here
|
|
|
|
|
|
(%heading (3 :semantics) "PrototypeFunction")
|
|
(define -prototype-function class
|
|
(new class
|
|
(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))
|
|
-function (delay -function-prototype) true
|
|
"Function" "function" :uninit true true null hint-string
|
|
ordinary-has-property 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-coerce)) ;***** Need to set prototype here.
|
|
|
|
|
|
(%heading (2 :semantics) "Package")
|
|
(define -package class
|
|
(new class
|
|
(list-set-of local-binding) (list-set-of instance-property) -object (delay -object-prototype) true
|
|
"Package" "object" :uninit true true null hint-string
|
|
ordinary-has-property 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-coerce))
|
|
|
|
|
|
(%heading (2 :semantics) "Error")
|
|
(define -error class
|
|
(new class
|
|
(list-set-of local-binding)
|
|
(%list-set-of instance-property
|
|
(new instance-variable (list-set (new qualified-name public "name")) false true -string null false)
|
|
(new instance-variable (list-set (new qualified-name public "message")) false true -string null false))
|
|
-object (delay -error-prototype) true
|
|
"Error" "object" :uninit true false null hint-number
|
|
ordinary-has-property ordinary-bracket-read ordinary-bracket-write ordinary-bracket-delete ordinary-read ordinary-write ordinary-delete ordinary-enumerate
|
|
call-error ordinary-construct init-error ordinary-is ordinary-coerce))
|
|
|
|
(define (call-error (this object :unused) (c class) (args (vector object)) (phase phase)) object
|
|
(rwhen (> (length args) 1)
|
|
(throw-error -argument-error "at most one argument can be supplied"))
|
|
(const arg object (default-arg args 0 undefined))
|
|
(if (or (in arg (tag null)) (is arg -error))
|
|
(return arg)
|
|
(return (construct c args phase))))
|
|
|
|
(define (init-error (this simple-instance) (args (vector object)) (phase (tag run))) void
|
|
(rwhen (> (length args) 1)
|
|
(throw-error -argument-error "at most one argument can be supplied"))
|
|
(const name (union string null) (assert-in (dot-read -error-prototype (list-set (new qualified-name public "name")) phase) (union string null)))
|
|
(dot-write this (list-set (new qualified-name public "name")) name phase)
|
|
(const arg object (default-arg args 0 undefined))
|
|
(var message (union string null))
|
|
(if (in arg (tag undefined))
|
|
(<- message (assert-in (dot-read -error-prototype (list-set (new qualified-name public "message")) phase) (union string null)))
|
|
(<- message (object-to-string arg phase)))
|
|
(dot-write this (list-set (new qualified-name public "message")) message phase))
|
|
|
|
|
|
(define -error-prototype simple-instance
|
|
(new simple-instance
|
|
(%list-set
|
|
(std-const-binding (new qualified-name public "constructor") -class -error)
|
|
(std-function (new qualified-name public "toString") -error_to-string 1)
|
|
(std-var-binding (new qualified-name public "name") -string "Error")
|
|
(std-var-binding (new qualified-name public "message") -string (/*/ "ErrorPrototypeMessage" "an implementation-defined string")))
|
|
-object-prototype prototypes-sealed -object
|
|
(list-set-of slot) none none none))
|
|
|
|
|
|
(define (-error_to-string (this object) (f simple-instance :unused) (args (vector object) :unused) (phase phase)) string
|
|
(rwhen (in phase (tag compile))
|
|
(throw-error -constant-error (:character-literal "toString") " cannot be called on an " (:character-literal "Error") " from a constant expression"))
|
|
(note "This function ignores any arguments passed to it in " (:local args) ".")
|
|
(const err object (coerce-non-null this -error))
|
|
(const name (union string null) (assert-in (dot-read err (list-set (new qualified-name public "name")) phase) (union string null)))
|
|
(const message (union string null) (assert-in (dot-read err (list-set (new qualified-name public "message")) phase) (union string null)))
|
|
(return (/*/ (append (object-to-string name phase) ": " (object-to-string message phase))
|
|
"an implementation-defined string derived from " (:local name) ", " (:local message) ", and optionally other properties of " (:local err))))
|
|
|
|
|
|
|
|
;***** Describe what I do.
|
|
(define (system-error (e class) (msg (union string undefined))) object
|
|
(return (construct e (vector-of object msg) run)))
|
|
|
|
|
|
(%heading (3 :semantics) "Error Subclasses")
|
|
(define (make-built-in-error-subclass (name string)) class
|
|
(function (call (this object :unused) (c class) (args (vector object)) (phase phase)) object
|
|
(rwhen (> (length args) 1)
|
|
(throw-error -argument-error "at most one argument can be supplied"))
|
|
(const arg object (default-arg args 0 undefined))
|
|
(if (or (in arg (tag null)) (is arg -error))
|
|
(return (coerce arg c))
|
|
(return (construct c args phase))))
|
|
(const c class
|
|
(new class
|
|
(list-set-of local-binding) (list-set-of instance-property) -error :uninit false
|
|
name "object" :uninit true false null hint-number
|
|
(& has-property -error) (& bracket-read -error) (& bracket-write -error) (& bracket-delete -error)
|
|
(& read -error) (& write -error) (& delete -error)
|
|
(& enumerate -error)
|
|
call ordinary-construct none ordinary-is ordinary-coerce))
|
|
(const prototype simple-instance
|
|
(new simple-instance
|
|
(%list-set
|
|
(std-const-binding (new qualified-name public "constructor") -class c)
|
|
(std-var-binding (new qualified-name public "name") -string name)
|
|
(std-var-binding (new qualified-name public "message") -string (/*/ (append name "PrototypeMessage") "an implementation-defined string")))
|
|
-error-prototype prototypes-sealed -object
|
|
(list-set-of slot) none none none))
|
|
(function (init (this simple-instance) (args (vector object)) (phase (tag run))) void
|
|
(rwhen (> (length args) 1)
|
|
(throw-error -argument-error "at most one argument can be supplied"))
|
|
(const name2 (union string null) (assert-in (dot-read prototype (list-set (new qualified-name public "name")) phase) (union string null)))
|
|
(dot-write this (list-set (new qualified-name public "name")) name2 phase)
|
|
(const arg object (default-arg args 0 undefined))
|
|
(var message (union string null))
|
|
(if (in arg (tag undefined))
|
|
(<- message (assert-in (dot-read prototype (list-set (new qualified-name public "message")) phase) (union string null)))
|
|
(<- message (object-to-string arg phase)))
|
|
(dot-write this (list-set (new qualified-name public "message")) message phase))
|
|
(&const= prototype c prototype)
|
|
(&= init c init)
|
|
(&= complete c true)
|
|
(return c))
|
|
|
|
|
|
(define -argument-error class (make-built-in-error-subclass "ArgumentError"))
|
|
(define -attribute-error class (make-built-in-error-subclass "AttributeError"))
|
|
(define -constant-error class (make-built-in-error-subclass "ConstantError"))
|
|
(define -definition-error class (make-built-in-error-subclass "DefinitionError"))
|
|
(define -eval-error class (make-built-in-error-subclass "EvalError"))
|
|
(define -range-error class (make-built-in-error-subclass "RangeError"))
|
|
(define -reference-error class (make-built-in-error-subclass "ReferenceError"))
|
|
(define -syntax-error class (make-built-in-error-subclass "SyntaxError"))
|
|
(define -type-error class (make-built-in-error-subclass "TypeError"))
|
|
(define -uninitialized-error class (make-built-in-error-subclass "UninitializedError"))
|
|
(define -u-r-i-error class (make-built-in-error-subclass "URIError"))
|
|
|
|
|
|
(? hide
|
|
(%heading (1 :semantics) "Pretty Printing")
|
|
|
|
(define (object-to-source (o object)) string
|
|
(case o
|
|
(:narrow (union undefined null boolean) (return (object-to-string o run)))
|
|
(:narrow long (return (append (general-number-to-string o) "L")))
|
|
(:narrow u-long (return (append (general-number-to-string o) "UL")))
|
|
(:select (tag nan32) (return "NaN_f"))
|
|
(:select (tag +zero32) (return "+0.0f"))
|
|
(:select (tag -zero32) (return "-0.0f"))
|
|
(:select (tag +infinity32) (return "Infinity_f"))
|
|
(:select (tag -infinity32) (return "-Infinity_f"))
|
|
(:narrow nonzero-finite-float32 (return (append (general-number-to-string o) "f")))
|
|
(:select (tag nan64) (return "NaN"))
|
|
(:select (tag +zero64) (return "+0.0"))
|
|
(:select (tag -zero64) (return "-0.0"))
|
|
(:select (tag +infinity64) (return "Infinity"))
|
|
(:select (tag -infinity64) (return "-Infinity"))
|
|
(:narrow nonzero-finite-float64 (return (general-number-to-string o)))
|
|
(:narrow char16 (return (vector #\' o #\')))
|
|
(:narrow string (return (append "\"" o "\"")))
|
|
(:narrow namespace (return (append "Namespace \"" (object-to-string o run) "\"")))
|
|
(:narrow compound-attribute (return (append "CompoundAttribute \"" (object-to-string o run) "\"")))
|
|
(:narrow class (return (append "Class " (& name o))))
|
|
(:narrow simple-instance (return (append "SimpleInstance \"" (object-to-string o run) "\"")))
|
|
(:narrow method-closure (return "MethodClosure"))
|
|
(:narrow date (return (append "Date \"" (object-to-string o run) "\"")))
|
|
(:narrow reg-exp (return (append "RegExp \"" (object-to-string o run) "\"")))
|
|
(:narrow package (return (append "Package \"" (object-to-string o run) "\""))))))
|
|
|
|
))
|
|
|
|
|
|
(defparameter *jw* (generate-world "J" *jw-source* '((js2 . :js2) (es4 . :es4) (hide . :hide))))
|
|
(defparameter *jg* (world-grammar *jw* 'code-grammar))
|
|
(ensure-lf-subset *jg*)
|
|
(forward-parser-states *jg*)
|
|
#+allegro (clean-grammar *jg*) ;Remove this line if you wish to print the grammar's state tables.
|
|
|
|
(defparameter *ew* nil)
|
|
(defparameter *eg* nil)
|
|
|
|
(defun compute-ecma-subset ()
|
|
(unless *ew*
|
|
(setq *ew* (generate-world "E" *jw-source* '((js2 . delete) (es4 . nil) (hide . :hide))))
|
|
(setq *eg* (world-grammar *ew* 'code-grammar))
|
|
(ensure-lf-subset *eg*)
|
|
(forward-parser-states *eg*))
|
|
(length (grammar-states *eg*)))
|
|
|
|
|
|
; Print a list of states that have both $REGULAR-EXPRESSION and either / or /= as valid lookaheads.
|
|
(defun show-regexp-and-division-states (grammar)
|
|
(all-state-transitions
|
|
#'(lambda (state transitions-hash)
|
|
(when (and (gethash '$regular-expression transitions-hash)
|
|
(or (gethash '/ transitions-hash) (gethash '/= transitions-hash)))
|
|
(format *error-output* "State ~S~%" state)))
|
|
grammar))
|
|
|
|
|
|
; Return five values:
|
|
; A list of terminals that may precede a $regular-expression terminal;
|
|
; A list of terminals that may precede a $virtual-semicolon but not / or /= terminal;
|
|
; A list of terminals that may precede a / or /= terminal;
|
|
; The intersection of the $regular-expression and /|/= lists.
|
|
; The intersection of the $regular-expression|$virtual-semicolon and /|/= lists.
|
|
;
|
|
; USE ONLY ON canonical-lr-1 grammars.
|
|
; DON'T RUN THIS AFTER CALLING forward-parser-states.
|
|
(defun show-regexp-and-division-predecessors (grammar)
|
|
(let* ((nstates (length (grammar-states grammar)))
|
|
(state-predecessors (make-array nstates :element-type 'terminalset :initial-element *empty-terminalset*)))
|
|
(dolist (state (grammar-states grammar))
|
|
(dolist (transition-pair (state-transitions state))
|
|
(let ((transition (cdr transition-pair)))
|
|
(when (eq (transition-kind transition) :shift)
|
|
(terminalset-union-f (svref state-predecessors (state-number (transition-state transition)))
|
|
(make-terminalset grammar (car transition-pair)))))))
|
|
(let ((regexp-predecessors *empty-terminalset*)
|
|
(virtual-predecessors *empty-terminalset*)
|
|
(div-predecessors *empty-terminalset*))
|
|
(all-state-transitions
|
|
#'(lambda (state transitions-hash)
|
|
(let ((predecessors (svref state-predecessors (state-number state))))
|
|
(when (gethash '$regular-expression transitions-hash)
|
|
(terminalset-union-f regexp-predecessors predecessors))
|
|
(if (or (gethash '/ transitions-hash) (gethash '/= transitions-hash))
|
|
(terminalset-union-f div-predecessors predecessors)
|
|
(when (gethash '$virtual-semicolon transitions-hash)
|
|
(terminalset-union-f virtual-predecessors predecessors)))))
|
|
grammar)
|
|
(values
|
|
(terminalset-list grammar regexp-predecessors)
|
|
(terminalset-list grammar virtual-predecessors)
|
|
(terminalset-list grammar div-predecessors)
|
|
(terminalset-list grammar (terminalset-intersection regexp-predecessors div-predecessors))
|
|
(terminalset-list grammar (terminalset-intersection (terminalset-union regexp-predecessors virtual-predecessors) div-predecessors))))))
|
|
|
|
|
|
(defun depict-js-terminals (markup-stream grammar heading)
|
|
(labels
|
|
((production-first-terminal (production)
|
|
(first (production-rhs production)))
|
|
|
|
(terminal-bin (terminal)
|
|
(if (and terminal (symbolp terminal))
|
|
(let ((name (symbol-name terminal)))
|
|
(if (> (length name) 0)
|
|
(let ((first-char (char name 0)))
|
|
(cond
|
|
((char= first-char #\$) 0)
|
|
((not (or (char= first-char #\_) (alphanumericp first-char))) 1)
|
|
((member terminal (rule-productions (grammar-rule grammar :identifier)) :key #'production-first-terminal) 5)
|
|
(t 3)))
|
|
1))
|
|
1))
|
|
|
|
(depict-terminal-bin (bin-name bin-terminals)
|
|
(when bin-terminals
|
|
(depict-paragraph (markup-stream :body-text)
|
|
(depict markup-stream bin-name)
|
|
(depict-list markup-stream #'depict-terminal bin-terminals :separator " ")))))
|
|
|
|
(let* ((bins (make-array 6 :initial-element nil))
|
|
(all-terminals (grammar-terminals grammar))
|
|
(terminals (remove-if #'lf-terminal? all-terminals)))
|
|
(assert-true (= (length all-terminals) (1- (* 2 (length terminals)))))
|
|
(setf (svref bins 2) (list '&&= '^^ '^^= '\|\|=))
|
|
(setf (svref bins 4) (list 'abstract 'class 'const 'debugger 'enum 'export 'extends 'goto 'implements 'import
|
|
'instanceof 'interface 'native 'package 'private 'protected 'public 'super 'synchronized
|
|
'throws 'transient 'volatile))
|
|
; Used to be reserved in JavaScript 1.5: 'boolean 'byte 'char 'double 'float 'int 'long 'short
|
|
(do ((i (length terminals)))
|
|
((zerop i))
|
|
(let ((terminal (aref terminals (decf i))))
|
|
(unless (eq terminal *end-marker*)
|
|
(setf (svref bins 2) (delete terminal (svref bins 2)))
|
|
(setf (svref bins 4) (delete terminal (svref bins 4)))
|
|
(push terminal (svref bins (terminal-bin terminal))))))
|
|
(depict-paragraph (markup-stream heading)
|
|
(depict-link (markup-stream :definition "terminals" "" nil)
|
|
(depict markup-stream "Terminals")))
|
|
(mapc #'depict-terminal-bin '("General tokens: " "Punctuation tokens: " "Future punctuation tokens: "
|
|
"Reserved words: " "Future reserved words: " "Non-reserved words: ")
|
|
(coerce bins 'list)))))
|
|
|
|
|
|
(defun dump-parser ()
|
|
(values
|
|
(length (grammar-states *jg*))
|
|
(depict-rtf-to-local-file
|
|
"JS20/ParserGrammarJS2.rtf"
|
|
"JavaScript 2.0 Syntactic Grammar"
|
|
#'(lambda (markup-stream)
|
|
(depict-js-terminals markup-stream *jg* :heading1)
|
|
(depict-world-commands markup-stream *jw* :visible-semantics nil)))
|
|
(depict-rtf-to-local-file
|
|
"JS20/ParserSemanticsJS2.rtf"
|
|
"JavaScript 2.0 Syntactic Semantics"
|
|
#'(lambda (markup-stream)
|
|
(depict-js-terminals markup-stream *jg* :heading1)
|
|
(depict-world-commands markup-stream *jw*)))
|
|
(compute-ecma-subset)
|
|
(depict-rtf-to-local-file
|
|
"JS20/ParserGrammarES4.rtf"
|
|
"ECMAScript Edition 4 Syntactic Grammar"
|
|
#'(lambda (markup-stream)
|
|
(depict-js-terminals markup-stream *eg* :heading1)
|
|
(depict-world-commands markup-stream *ew* :visible-semantics nil)))
|
|
(depict-rtf-to-local-file
|
|
"JS20/ParserSemanticsES4.rtf"
|
|
"ECMAScript Edition 4 Syntactic Semantics"
|
|
#'(lambda (markup-stream)
|
|
(depict-js-terminals markup-stream *eg* :heading1)
|
|
(depict-world-commands markup-stream *ew*)))
|
|
|
|
(length (grammar-states *jg*))
|
|
(depict-html-to-local-file
|
|
"JS20/ParserGrammarJS2.html"
|
|
"JavaScript 2.0 Syntactic Grammar"
|
|
t
|
|
#'(lambda (markup-stream)
|
|
(depict-js-terminals markup-stream *jg* :heading2)
|
|
(depict-world-commands markup-stream *jw* :heading-offset 1 :visible-semantics nil))
|
|
:external-link-base "notation.html")
|
|
(depict-html-to-local-file
|
|
"JS20/ParserSemanticsJS2.html"
|
|
"JavaScript 2.0 Syntactic Semantics"
|
|
t
|
|
#'(lambda (markup-stream)
|
|
(depict-js-terminals markup-stream *jg* :heading1)
|
|
(depict-world-commands markup-stream *jw*))
|
|
:external-link-base "notation.html")
|
|
(compute-ecma-subset)
|
|
(depict-html-to-local-file
|
|
"JS20/ParserGrammarES4.html"
|
|
"ECMAScript Edition 4 Syntactic Grammar"
|
|
t
|
|
#'(lambda (markup-stream)
|
|
(depict-js-terminals markup-stream *eg* :heading2)
|
|
(depict-world-commands markup-stream *ew* :heading-offset 1 :visible-semantics nil))
|
|
:external-link-base "notation.html")
|
|
(depict-html-to-local-file
|
|
"JS20/ParserSemanticsES4.html"
|
|
"ECMAScript Edition 4 Syntactic Semantics"
|
|
t
|
|
#'(lambda (markup-stream)
|
|
(depict-js-terminals markup-stream *eg* :heading1)
|
|
(depict-world-commands markup-stream *ew*))
|
|
:external-link-base "notation.html")))
|
|
|
|
|
|
#|
|
|
(dump-parser)
|
|
|
|
(depict-rtf-to-local-file
|
|
"JS20/ParserSemanticsJS2.rtf"
|
|
"JavaScript 2.0 Syntactic Semantics"
|
|
#'(lambda (markup-stream)
|
|
(depict-js-terminals markup-stream *jg* :heading1)
|
|
(depict-world-commands markup-stream *jw*)))
|
|
|
|
(depict-html-to-local-file
|
|
"JS20/ParserSemanticsJS2.html"
|
|
"JavaScript 2.0 Syntactic Semantics"
|
|
t
|
|
#'(lambda (markup-stream)
|
|
(depict-js-terminals markup-stream *jg* :heading1)
|
|
(depict-world-commands markup-stream *jw*))
|
|
:external-link-base "notation.html")
|
|
|
|
|
|
(with-local-output (s "JS20/ParserGrammarJS2 states") (print-grammar *jg* s))
|
|
(compute-ecma-subset)
|
|
(with-local-output (s "JS20/ParserGrammarES4 states") (print-grammar *eg* s))
|
|
|#
|
|
|
|
(length (grammar-states *jg*))
|