mirror of
https://github.com/mozilla/gecko-dev.git
synced 2025-02-23 10:54:33 +00:00
Added support for list-sets, some, and every. Removed tuple and record tags. Made many minor semantic notation improvements.
This commit is contained in:
waldemar%netscape.com
parent
8a5b30145d
commit
2fc37b5493
File diff suppressed because it is too large
Load Diff
@ -43,7 +43,9 @@
|
||||
;;; SEMANTIC DEPICTION UTILITIES
|
||||
|
||||
(defparameter *semantic-keywords*
|
||||
'(not and or xor mod new
|
||||
'(not and or xor mod new eltof
|
||||
some every satisfies
|
||||
such that
|
||||
tag tuple record
|
||||
function
|
||||
begin end nothing
|
||||
@ -178,6 +180,7 @@
|
||||
; :definition if this is a definition of this tag;
|
||||
; nil if this use of the tag should not be cross-referenced.
|
||||
(defun depict-tag-name (markup-stream tag link)
|
||||
(assert-true (tag-keyword tag))
|
||||
(when (eq link :reference)
|
||||
(setq link (tag-link tag)))
|
||||
(multiple-value-bind (link-name name) (tag-link-name-and-name tag)
|
||||
@ -186,23 +189,20 @@
|
||||
(depict-item-or-list markup-stream name)))))
|
||||
|
||||
|
||||
; Emit markup for a tag's label, which must be a symbol. tag may be null, in
|
||||
; which case no link is generated.
|
||||
; Emit markup for a tuple or record type's label, which must be a symbol.
|
||||
; link should be one of:
|
||||
; :reference if this is a reference or external reference to this label;
|
||||
; nil if this use of the label should not be cross-referenced.
|
||||
(defun depict-label-name (markup-stream tag label link)
|
||||
(if tag
|
||||
(progn
|
||||
(unless (tag-find-field tag label)
|
||||
(error "Tag ~A doesn't have label ~A" tag label))
|
||||
(when (eq link :reference)
|
||||
(setq link (tag-link tag)))
|
||||
(depict-link (markup-stream link "R-" (tag-link-name-and-name tag) nil)
|
||||
(depict-char-style (markup-stream :field-name)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name label)))))
|
||||
(depict-char-style (markup-stream :field-name)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name label)))))
|
||||
(defun depict-label-name (markup-stream type label link)
|
||||
(unless (type-has-field type label)
|
||||
(error "Type ~A doesn't have label ~A" type label))
|
||||
(let ((type-name (type-name type)))
|
||||
(unless type-name
|
||||
(warn "Accessing field ~A of anonymous type ~S" label type)
|
||||
(setq link nil))
|
||||
(depict-link (markup-stream link "T-" (symbol-upper-mixed-case-name type-name) nil)
|
||||
(depict-char-style (markup-stream :field-name)
|
||||
(depict markup-stream (symbol-lower-mixed-case-name label))))))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
@ -277,7 +277,7 @@
|
||||
(depict markup-stream "[]")))
|
||||
|
||||
|
||||
; (set <element-type>)
|
||||
; (range-set <element-type>)
|
||||
; "<element-type>{}"
|
||||
(defun depict-set (markup-stream world level element-type-expr)
|
||||
(depict-type-parentheses (markup-stream level %%suffix%%)
|
||||
@ -292,14 +292,7 @@
|
||||
(depict-list
|
||||
markup-stream
|
||||
#'(lambda (markup-stream tag-name)
|
||||
(let* ((tag (scan-tag world tag-name))
|
||||
(mutable (tag-mutable tag)))
|
||||
(depict-tag-name markup-stream tag :reference)
|
||||
(unless (tag-keyword tag)
|
||||
(depict markup-stream
|
||||
(if mutable :record-begin :tuple-begin)
|
||||
"..."
|
||||
(if mutable :record-end :tuple-end)))))
|
||||
(depict-tag-name markup-stream (scan-tag world tag-name) :reference))
|
||||
tag-names
|
||||
:indent 1
|
||||
:prefix "{"
|
||||
@ -547,11 +540,11 @@
|
||||
(if annotated-exprs
|
||||
(depict-expr-parentheses (markup-stream level %logical%)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-expression markup-stream world annotated-expr %not%)
|
||||
(depict-expression markup-stream world annotated-expr %relational%)
|
||||
(dolist (annotated-expr annotated-exprs)
|
||||
(depict-semantic-keyword markup-stream op :before)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-expression markup-stream world annotated-expr %not%))))
|
||||
(depict-expression markup-stream world annotated-expr %relational%))))
|
||||
(depict-expression markup-stream world annotated-expr level)))
|
||||
|
||||
|
||||
@ -608,23 +601,20 @@
|
||||
; (if <condition-expr> <true-expr> <false-expr>)
|
||||
(defun depict-if-expr (markup-stream world level condition-annotated-expr true-annotated-expr false-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %expr%)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-semantic-keyword markup-stream 'if :after)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-expression markup-stream world condition-annotated-expr %logical%))
|
||||
(depict-expression markup-stream world condition-annotated-expr %logical%)
|
||||
(depict markup-stream " ?")
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-semantic-keyword markup-stream 'then :after)
|
||||
(depict-logical-block (markup-stream 7)
|
||||
(depict-expression markup-stream world true-annotated-expr %expr%))
|
||||
(depict-expression markup-stream world true-annotated-expr %logical%)
|
||||
(depict markup-stream " :")
|
||||
(depict-break markup-stream 1)
|
||||
(depict-semantic-keyword markup-stream 'else :after)
|
||||
(depict-logical-block (markup-stream (if (special-form-annotated-expr? world 'if false-annotated-expr) nil 6))
|
||||
(depict-expression markup-stream world false-annotated-expr %expr%)))))
|
||||
(depict-expression markup-stream world false-annotated-expr %logical%))))
|
||||
|
||||
|
||||
;;; Vectors
|
||||
|
||||
; (vector <element-expr> <element-expr> ... <element-expr>)
|
||||
; (vector-of <element-type> <element-expr> ... <element-expr>)
|
||||
(defun depict-vector-expr (markup-stream world level &rest element-annotated-exprs)
|
||||
(declare (ignore level))
|
||||
(if element-annotated-exprs
|
||||
@ -656,32 +646,6 @@
|
||||
|#
|
||||
|
||||
|
||||
; (empty <vector-expr>)
|
||||
(defun depict-empty (markup-stream world level vector-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %relational%)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-length markup-stream world %term% vector-annotated-expr)
|
||||
(depict markup-stream " = ")
|
||||
(depict-constant markup-stream 0))))
|
||||
|
||||
|
||||
; (nonempty <vector-expr>)
|
||||
(defun depict-nonempty (markup-stream world level vector-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %relational%)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-length markup-stream world %term% vector-annotated-expr)
|
||||
(depict markup-stream " " :not-equal " ")
|
||||
(depict-constant markup-stream 0))))
|
||||
|
||||
|
||||
; (length <vector-expr>)
|
||||
(defun depict-length (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict markup-stream "|")
|
||||
(depict-expression markup-stream world vector-annotated-expr %expr%)
|
||||
(depict markup-stream "|"))
|
||||
|
||||
|
||||
; (nth <vector-expr> <n-expr>)
|
||||
(defun depict-nth (markup-stream world level vector-annotated-expr n-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %suffix%)
|
||||
@ -728,30 +692,27 @@
|
||||
(depict markup-stream "]"))))
|
||||
|
||||
|
||||
; (map <vector-expr> <var> <value-expr> [<condition-expr>])
|
||||
(defun depict-map (markup-stream world level vector-annotated-expr var value-annotated-expr &optional condition-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict markup-stream :vector-begin)
|
||||
(depict-expression markup-stream world value-annotated-expr %expr%)
|
||||
(depict markup-stream " " :vector-construct)
|
||||
(depict-break markup-stream 1)
|
||||
(depict markup-stream :for-all-10)
|
||||
(depict-local-variable markup-stream var)
|
||||
(depict markup-stream " " :member-10 " ")
|
||||
(depict-expression markup-stream world vector-annotated-expr %term%)
|
||||
(when condition-annotated-expr
|
||||
(depict-semantic-keyword markup-stream 'and :before)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-expression markup-stream world condition-annotated-expr %not%))
|
||||
(depict markup-stream :vector-end)))
|
||||
|
||||
|
||||
;;; Sets
|
||||
|
||||
; (set-of-ranges <element-type> <low-expr> <high-expr> ... <low-expr> <high-expr>)
|
||||
(defun depict-set-of-ranges (markup-stream world level element-type-expr &rest element-annotated-exprs)
|
||||
(declare (ignore level element-type-expr))
|
||||
; (list-set <element-expr> ... <element-expr>)
|
||||
; (list-set-of <element-type> <element-expr> ... <element-expr>)
|
||||
(defun depict-list-set-expr (markup-stream world level &rest element-annotated-exprs)
|
||||
(declare (ignore level))
|
||||
(depict-list markup-stream
|
||||
#'(lambda (markup-stream element-annotated-expr)
|
||||
(depict-expression markup-stream world element-annotated-expr %expr%))
|
||||
element-annotated-exprs
|
||||
:indent 1
|
||||
:prefix "{"
|
||||
:suffix "}"
|
||||
:separator ","
|
||||
:break 1
|
||||
:empty nil))
|
||||
|
||||
|
||||
; (range-set-of-ranges <element-type> <low-expr> <high-expr> ... <low-expr> <high-expr>)
|
||||
(defun depict-range-set-of-ranges (markup-stream world level &rest element-annotated-exprs)
|
||||
(declare (ignore level))
|
||||
(labels
|
||||
((combine-exprs (element-annotated-exprs)
|
||||
(if (endp element-annotated-exprs)
|
||||
@ -776,18 +737,137 @@
|
||||
:empty nil)))
|
||||
|
||||
|
||||
;;; Tags
|
||||
; (set* <set-expr> <set-expr>)
|
||||
(defun depict-set* (markup-stream world level set1-annotated-expr set2-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %factor%)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-expression markup-stream world set1-annotated-expr %factor%)
|
||||
(depict markup-stream " " :intersection-10)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-expression markup-stream world set2-annotated-expr %factor%))))
|
||||
|
||||
|
||||
; (set+ <set-expr> <set-expr>)
|
||||
(defun depict-set+ (markup-stream world level set1-annotated-expr set2-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %term%)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-expression markup-stream world set1-annotated-expr %term%)
|
||||
(depict markup-stream " " :union-10)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-expression markup-stream world set2-annotated-expr %term%))))
|
||||
|
||||
|
||||
; (set- <set-expr> <set-expr>)
|
||||
(defun depict-set- (markup-stream world level set1-annotated-expr set2-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %term%)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-expression markup-stream world set1-annotated-expr %term%)
|
||||
(depict markup-stream " " :minus)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-expression markup-stream world set2-annotated-expr %factor%))))
|
||||
|
||||
|
||||
; (set-in <elt-expr> <set-expr>)
|
||||
; (set-not-in <elt-expr> <set-expr>)
|
||||
(defun depict-set-in (markup-stream world level op elt-annotated-expr set-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %relational%)
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-expression markup-stream world elt-annotated-expr %term%)
|
||||
(depict markup-stream " " op)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-expression markup-stream world set-annotated-expr %term%))))
|
||||
|
||||
|
||||
; (elt-of <elt-expr>)
|
||||
(defun depict-elt-of (markup-stream world level set-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %min-max%)
|
||||
(depict-semantic-keyword markup-stream 'eltof :after)
|
||||
(depict-expression markup-stream world set-annotated-expr %prefix%)))
|
||||
|
||||
|
||||
;;; Vectors or Sets
|
||||
|
||||
(defun depict-empty-set-or-vector (markup-stream kind)
|
||||
(ecase kind
|
||||
((:string :vector) (depict markup-stream :empty-vector))
|
||||
((:list-set :range-set) (depict markup-stream "{}"))))
|
||||
|
||||
|
||||
; (empty <vector-or-set-expr>)
|
||||
(defun depict-empty (markup-stream world level kind vector-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %relational%)
|
||||
(depict-expression markup-stream world vector-annotated-expr %term%)
|
||||
(depict markup-stream " = ")
|
||||
(depict-empty-set-or-vector markup-stream kind)))
|
||||
|
||||
|
||||
; (nonempty <vector-or-set-expr>)
|
||||
(defun depict-nonempty (markup-stream world level kind vector-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %relational%)
|
||||
(depict-expression markup-stream world vector-annotated-expr %term%)
|
||||
(depict markup-stream " " :not-equal " ")
|
||||
(depict-empty-set-or-vector markup-stream kind)))
|
||||
|
||||
|
||||
; (length <vector-or-set-expr>)
|
||||
(defun depict-length (markup-stream world level vector-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(depict markup-stream "|")
|
||||
(depict-expression markup-stream world vector-annotated-expr %expr%)
|
||||
(depict markup-stream "|"))
|
||||
|
||||
|
||||
; (some <vector-or-set-expr> <var> <condition-expr>)
|
||||
; (every <vector-or-set-expr> <var> <condition-expr>)
|
||||
(defun depict-some (markup-stream world level keyword collection-annotated-expr var condition-annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %expr%)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict-semantic-keyword markup-stream keyword :after)
|
||||
(depict-local-variable markup-stream var)
|
||||
(depict markup-stream " " :member-10 " ")
|
||||
(depict-expression markup-stream world collection-annotated-expr %term%)
|
||||
(depict-semantic-keyword markup-stream 'satisfies :before)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-expression markup-stream world condition-annotated-expr %logical%))))
|
||||
|
||||
|
||||
; (map <vector-or-set-expr> <var> <value-expr> [<condition-expr>])
|
||||
(defun depict-map (markup-stream world level collection-kind collection-annotated-expr var value-annotated-expr &optional condition-annotated-expr)
|
||||
(declare (ignore level))
|
||||
(multiple-value-bind (open bar close)
|
||||
(ecase collection-kind
|
||||
((:string :vector) (values :vector-begin :vector-construct :vector-end))
|
||||
((:list-set :range-set) (values "{" "|" "}")))
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(depict markup-stream open)
|
||||
(depict-expression markup-stream world value-annotated-expr %expr%)
|
||||
(depict markup-stream " " bar)
|
||||
(depict-break markup-stream 1)
|
||||
(depict markup-stream :for-all-10)
|
||||
(depict-local-variable markup-stream var)
|
||||
(depict markup-stream " " :member-10 " ")
|
||||
(depict-expression markup-stream world collection-annotated-expr %term%)
|
||||
(when condition-annotated-expr
|
||||
(depict-semantic-keyword markup-stream 'such :before)
|
||||
(depict-semantic-keyword markup-stream 'that :before)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-expression markup-stream world condition-annotated-expr %logical%))
|
||||
(depict markup-stream close))))
|
||||
|
||||
|
||||
;;; Tuples and Records
|
||||
|
||||
(defparameter *depict-tag-labels* nil)
|
||||
|
||||
; (tag <tag> <field-expr1> ... <field-exprn>)
|
||||
(defun depict-tag-expr (markup-stream world level tag &rest annotated-exprs)
|
||||
(let ((mutable (tag-mutable tag)))
|
||||
; (new <type> <field-expr1> ... <field-exprn>)
|
||||
(defun depict-new (markup-stream world level type type-name &rest annotated-exprs)
|
||||
(let* ((tag (type-tag type))
|
||||
(mutable (tag-mutable tag)))
|
||||
(flet
|
||||
((depict-tag-and-args (markup-stream)
|
||||
(let ((fields (tag-fields tag)))
|
||||
(assert-true (= (length fields) (length annotated-exprs)))
|
||||
(depict-tag-name markup-stream tag :reference)
|
||||
(depict-type-name markup-stream type-name :reference)
|
||||
(if (tag-keyword tag)
|
||||
(assert-true (null annotated-exprs))
|
||||
(depict-list markup-stream
|
||||
@ -795,7 +875,7 @@
|
||||
(let ((field (pop fields)))
|
||||
(if (and mutable *depict-tag-labels*)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-label-name markup-stream tag (field-label field) :reference)
|
||||
(depict-label-name markup-stream (symbol-type (tag-name tag)) (field-label field) :reference)
|
||||
(depict markup-stream " " :label-assign-10)
|
||||
(depict-break markup-stream 1)
|
||||
(depict-expression markup-stream world parameter %expr%))
|
||||
@ -818,19 +898,18 @@
|
||||
|
||||
|
||||
; (& <label> <record-expr>)
|
||||
(defun depict-& (markup-stream world level tags label annotated-expr)
|
||||
(defun depict-& (markup-stream world level record-type label annotated-expr)
|
||||
(depict-expr-parentheses (markup-stream level %suffix%)
|
||||
(depict-expression markup-stream world annotated-expr %suffix%)
|
||||
(depict markup-stream ".")
|
||||
(let ((tag (if (endp (cdr tags)) (car tags) nil)))
|
||||
(depict-label-name markup-stream tag label :reference))))
|
||||
(depict-label-name markup-stream record-type label :reference)))
|
||||
|
||||
|
||||
;;; Unions
|
||||
|
||||
(defun depict-in-or-not-in (markup-stream world level type type-expr value-annotated-expr op single-op)
|
||||
(defun depict-in-or-not-in (markup-stream world level value-annotated-expr type type-expr op single-op)
|
||||
(depict-expr-parentheses (markup-stream level %relational%)
|
||||
(depict-expression markup-stream world value-annotated-expr %suffix%)
|
||||
(depict-expression markup-stream world value-annotated-expr %term%)
|
||||
(depict-space markup-stream)
|
||||
(if (and (eq (type-kind type) :tag) (tag-keyword (type-tag type)))
|
||||
(progn
|
||||
@ -843,12 +922,12 @@
|
||||
(depict-type-expr markup-stream world type-expr)))))
|
||||
|
||||
; (in <type> <expr>)
|
||||
(defun depict-in (markup-stream world level type type-expr value-annotated-expr)
|
||||
(depict-in-or-not-in markup-stream world level type type-expr value-annotated-expr :member-10 "="))
|
||||
(defun depict-in (markup-stream world level value-annotated-expr type type-expr)
|
||||
(depict-in-or-not-in markup-stream world level value-annotated-expr type type-expr :member-10 "="))
|
||||
|
||||
; (not-in <type> <expr>)
|
||||
(defun depict-not-in (markup-stream world level type type-expr value-annotated-expr)
|
||||
(depict-in-or-not-in markup-stream world level type type-expr value-annotated-expr :not-member-10 :not-equal))
|
||||
(defun depict-not-in (markup-stream world level value-annotated-expr type type-expr)
|
||||
(depict-in-or-not-in markup-stream world level value-annotated-expr type type-expr :not-member-10 :not-equal))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
@ -879,7 +958,7 @@
|
||||
|
||||
; (exec <expr>)
|
||||
(defun depict-exec (markup-stream world annotated-expr)
|
||||
(depict-expression markup-stream world annotated-expr %logical%))
|
||||
(depict-expression markup-stream world annotated-expr %expr%))
|
||||
|
||||
|
||||
; (const <name> <type> <value>)
|
||||
@ -913,8 +992,8 @@
|
||||
|
||||
|
||||
; (&= <record-expr> <value-expr>)
|
||||
(defun depict-&= (markup-stream world tag label record-annotated-expr value-annotated-expr)
|
||||
(depict-& markup-stream world %unary% tag label record-annotated-expr)
|
||||
(defun depict-&= (markup-stream world record-type label record-annotated-expr value-annotated-expr)
|
||||
(depict-& markup-stream world %unary% record-type label record-annotated-expr)
|
||||
(depict markup-stream " " :assign-10)
|
||||
(depict-logical-block (markup-stream 6)
|
||||
(depict-break markup-stream 1)
|
||||
@ -927,7 +1006,7 @@
|
||||
(depict-semantic-keyword markup-stream 'return nil)
|
||||
(when value-annotated-expr
|
||||
(depict-space markup-stream)
|
||||
(depict-expression markup-stream world value-annotated-expr %logical%))))
|
||||
(depict-expression markup-stream world value-annotated-expr %expr%))))
|
||||
|
||||
|
||||
; (cond (<condition-expr> . <statements>) ... (<condition-expr> . <statements>) [(nil . <statements>)])
|
||||
@ -944,7 +1023,7 @@
|
||||
(progn
|
||||
(depict-semantic-keyword markup-stream (if else 'elsif 'if) :after)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-expression markup-stream world condition-annotated-expr %logical%))
|
||||
(depict-expression markup-stream world condition-annotated-expr %expr%))
|
||||
(depict-semantic-keyword markup-stream 'then :before))
|
||||
(depict-semantic-keyword markup-stream 'else nil)))
|
||||
(depict-statements markup-stream world 1 (rest annotated-case)))
|
||||
@ -959,7 +1038,7 @@
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-semantic-keyword markup-stream 'while :after)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-expression markup-stream world condition-annotated-expr %logical%))
|
||||
(depict-expression markup-stream world condition-annotated-expr %expr%))
|
||||
(depict-semantic-keyword markup-stream 'do :before)
|
||||
(depict-statements markup-stream world 1 loop-annotated-stmts))
|
||||
(depict-break markup-stream 1)
|
||||
@ -971,14 +1050,14 @@
|
||||
(defun depict-assert (markup-stream world condition-annotated-expr)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-semantic-keyword markup-stream 'invariant :after)
|
||||
(depict-expression markup-stream world condition-annotated-expr %logical%)))
|
||||
(depict-expression markup-stream world condition-annotated-expr %expr%)))
|
||||
|
||||
|
||||
; (throw <value-expr>)
|
||||
(defun depict-throw (markup-stream world value-annotated-expr)
|
||||
(depict-logical-block (markup-stream 4)
|
||||
(depict-semantic-keyword markup-stream 'throw :after)
|
||||
(depict-expression markup-stream world value-annotated-expr %logical%)))
|
||||
(depict-expression markup-stream world value-annotated-expr %expr%)))
|
||||
|
||||
|
||||
; (catch <body-statements> (<var> [:unused]) . <handler-statements>)
|
||||
@ -1010,7 +1089,7 @@
|
||||
(depict-logical-block (markup-stream 0)
|
||||
(depict-semantic-keyword markup-stream 'case :after)
|
||||
(depict-logical-block (markup-stream 8)
|
||||
(depict-expression markup-stream world value-annotated-expr %logical%))
|
||||
(depict-expression markup-stream world value-annotated-expr %expr%))
|
||||
(depict-semantic-keyword markup-stream 'of :before)
|
||||
(depict-list
|
||||
markup-stream
|
||||
@ -1175,30 +1254,40 @@
|
||||
(setf (depict-env-pending-actions-reverse depict-env) nil))
|
||||
|
||||
|
||||
; (deftag <name> (<name1> <type1>) ... (<namen> <typen>))
|
||||
; (defrecord <name> (<name1> <type1>) ... (<namen> <typen>))
|
||||
(defun depict-deftag (markup-stream world depict-env name &rest fields)
|
||||
; (deftag <name>)
|
||||
(defun depict-deftag (markup-stream world depict-env name)
|
||||
(depict-semantics (markup-stream depict-env)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(let* ((tag (scan-tag world name))
|
||||
(let ((tag (scan-tag world name)))
|
||||
(depict-semantic-keyword markup-stream 'tag :after)
|
||||
(depict-tag-name markup-stream tag :definition))
|
||||
(depict markup-stream ";"))))
|
||||
|
||||
|
||||
; (deftuple <name> (<name1> <type1>) ... (<namen> <typen>))
|
||||
; (defrecord <name> (<name1> <type1>) ... (<namen> <typen>))
|
||||
(defun depict-deftuple (markup-stream world depict-env name &rest fields)
|
||||
(depict-semantics (markup-stream depict-env)
|
||||
(depict-logical-block (markup-stream 2)
|
||||
(let* ((type (scan-kinded-type world name :tag))
|
||||
(tag (type-tag type))
|
||||
(mutable (tag-mutable tag)))
|
||||
(depict-semantic-keyword markup-stream (if mutable 'record (if fields 'tuple 'tag)) :after)
|
||||
(depict-tag-name markup-stream tag :definition)
|
||||
(when (or mutable fields)
|
||||
(depict-list
|
||||
markup-stream
|
||||
#'(lambda (markup-stream field)
|
||||
(depict-label-name markup-stream tag (first field) nil)
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world (second field) %%type%%))
|
||||
fields
|
||||
:indent 6
|
||||
:prefix (if mutable :record-begin :tuple-begin)
|
||||
:prefix-break 0
|
||||
:suffix (if mutable :record-end :tuple-end)
|
||||
:separator ","
|
||||
:break 1
|
||||
:empty nil)))
|
||||
(depict-semantic-keyword markup-stream (if mutable 'record 'tuple) :after)
|
||||
(depict-type-name markup-stream name :definition)
|
||||
(depict-list
|
||||
markup-stream
|
||||
#'(lambda (markup-stream field)
|
||||
(depict-label-name markup-stream type (first field) nil)
|
||||
(depict markup-stream ": ")
|
||||
(depict-type-expr markup-stream world (second field) %%type%%))
|
||||
fields
|
||||
:indent 6
|
||||
:prefix (if mutable :record-begin :tuple-begin)
|
||||
:prefix-break 0
|
||||
:suffix (if mutable :record-end :tuple-end)
|
||||
:separator ","
|
||||
:break 1
|
||||
:empty nil))
|
||||
(depict markup-stream ";"))))
|
||||
|
||||
|
||||
@ -1396,9 +1485,10 @@
|
||||
(setf (styled-text-depictor :tag) #'depict-styled-text-tag)
|
||||
|
||||
|
||||
; (:label <tag-name> <label>)
|
||||
(defun depict-styled-text-label (markup-stream tag-name label)
|
||||
(depict-label-name markup-stream (scan-tag *styled-text-world* tag-name) label :reference))
|
||||
; (:label <type-name> <label>)
|
||||
(defun depict-styled-text-label (markup-stream type-name label)
|
||||
(let ((type (scan-type *styled-text-world* type-name)))
|
||||
(depict-label-name markup-stream type label :reference)))
|
||||
|
||||
(setf (styled-text-depictor :label) #'depict-styled-text-label)
|
||||
|
||||
|
||||
@ -76,14 +76,13 @@
|
||||
(deftag line-break)
|
||||
(deftag end-of-input)
|
||||
|
||||
(deftag keyword (name string))
|
||||
(deftag punctuator (name string))
|
||||
(deftag identifier (name string))
|
||||
(deftag number (value float64))
|
||||
(deftag string (value string))
|
||||
(deftag regular-expression (body string) (flags string))
|
||||
(deftuple keyword (name string))
|
||||
(deftuple punctuator (name string))
|
||||
(deftuple identifier (name string))
|
||||
(deftuple number (value float64))
|
||||
(deftuple regular-expression (body string) (flags string))
|
||||
|
||||
(deftype token (tag keyword punctuator identifier number string regular-expression))
|
||||
(deftype token (union keyword punctuator identifier number string regular-expression))
|
||||
(deftype input-element (union (tag line-break end-of-input) token))
|
||||
|
||||
|
||||
@ -156,9 +155,9 @@
|
||||
(production (:next-input-element unit) ((:- :continuing-identifier-character #\\) :white-space (:input-element div)) next-input-element-unit-normal
|
||||
(lex (lex :input-element)))
|
||||
(production (:next-input-element unit) ((:- #\_) :identifier-name) next-input-element-unit-name
|
||||
(lex (tag string (lex-name :identifier-name))))
|
||||
(lex (lex-name :identifier-name)))
|
||||
#|(production (:next-input-element unit) (#\_ :identifier-name) next-input-element-unit-underscore-name
|
||||
(lex (tag string (lex-name :identifier-name))))|#)
|
||||
(lex (lex-name :identifier-name)))|#)
|
||||
|
||||
(%print-actions)
|
||||
|
||||
@ -258,82 +257,82 @@
|
||||
(lex (begin
|
||||
(const id string (lex-name :identifier-name))
|
||||
(if (and (member id keywords) (not (contains-escapes :identifier-name)))
|
||||
(return (tag keyword id))
|
||||
(return (tag identifier id)))))))
|
||||
(return (new keyword id))
|
||||
(return (new identifier id)))))))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Punctuators")
|
||||
|
||||
(rule :punctuator ((lex token))
|
||||
(production :punctuator (#\!) punctuator-not (lex (tag punctuator "!")))
|
||||
(production :punctuator (#\! #\=) punctuator-not-equal (lex (tag punctuator "!=")))
|
||||
(production :punctuator (#\! #\= #\=) punctuator-not-identical (lex (tag punctuator "!==")))
|
||||
(production :punctuator (#\#) punctuator-hash (lex (tag punctuator "#")))
|
||||
(production :punctuator (#\%) punctuator-modulo (lex (tag punctuator "%")))
|
||||
(production :punctuator (#\% #\=) punctuator-modulo-equals (lex (tag punctuator "%=")))
|
||||
(production :punctuator (#\&) punctuator-and (lex (tag punctuator "&")))
|
||||
(production :punctuator (#\& #\&) punctuator-logical-and (lex (tag punctuator "&&")))
|
||||
(production :punctuator (#\& #\& #\=) punctuator-logical-and-equals (lex (tag punctuator "&&=")))
|
||||
(production :punctuator (#\& #\=) punctuator-and-equals (lex (tag punctuator "&=")))
|
||||
(production :punctuator (#\() punctuator-open-parenthesis (lex (tag punctuator "(")))
|
||||
(production :punctuator (#\)) punctuator-close-parenthesis (lex (tag punctuator ")")))
|
||||
(production :punctuator (#\*) punctuator-times (lex (tag punctuator "*")))
|
||||
(production :punctuator (#\* #\=) punctuator-times-equals (lex (tag punctuator "*=")))
|
||||
(production :punctuator (#\+) punctuator-plus (lex (tag punctuator "+")))
|
||||
(production :punctuator (#\+ #\+) punctuator-increment (lex (tag punctuator "++")))
|
||||
(production :punctuator (#\+ #\=) punctuator-plus-equals (lex (tag punctuator "+=")))
|
||||
(production :punctuator (#\,) punctuator-comma (lex (tag punctuator ",")))
|
||||
(production :punctuator (#\-) punctuator-minus (lex (tag punctuator "-")))
|
||||
(production :punctuator (#\- #\-) punctuator-decrement (lex (tag punctuator "--")))
|
||||
(production :punctuator (#\- #\=) punctuator-minus-equals (lex (tag punctuator "-=")))
|
||||
(production :punctuator (#\- #\>) punctuator-arrow (lex (tag punctuator "->")))
|
||||
(production :punctuator (#\.) punctuator-dot (lex (tag punctuator ".")))
|
||||
(production :punctuator (#\. #\.) punctuator-double-dot (lex (tag punctuator "..")))
|
||||
(production :punctuator (#\. #\. #\.) punctuator-triple-dot (lex (tag punctuator "...")))
|
||||
(production :punctuator (#\:) punctuator-colon (lex (tag punctuator ":")))
|
||||
(production :punctuator (#\: #\:) punctuator-namespace (lex (tag punctuator "::")))
|
||||
(production :punctuator (#\;) punctuator-semicolon (lex (tag punctuator ";")))
|
||||
(production :punctuator (#\<) punctuator-less-than (lex (tag punctuator "<")))
|
||||
(production :punctuator (#\< #\<) punctuator-left-shift (lex (tag punctuator "<<")))
|
||||
(production :punctuator (#\< #\< #\=) punctuator-left-shift-equals (lex (tag punctuator "<<=")))
|
||||
(production :punctuator (#\< #\=) punctuator-less-than-or-equal (lex (tag punctuator "<=")))
|
||||
(production :punctuator (#\=) punctuator-assignment (lex (tag punctuator "=")))
|
||||
(production :punctuator (#\= #\=) punctuator-equal (lex (tag punctuator "==")))
|
||||
(production :punctuator (#\= #\= #\=) punctuator-identical (lex (tag punctuator "===")))
|
||||
(production :punctuator (#\>) punctuator-greater-than (lex (tag punctuator ">")))
|
||||
(production :punctuator (#\> #\=) punctuator-greater-than-or-equal (lex (tag punctuator ">=")))
|
||||
(production :punctuator (#\> #\>) punctuator-right-shift (lex (tag punctuator ">>")))
|
||||
(production :punctuator (#\> #\> #\=) punctuator-right-shift-equals (lex (tag punctuator ">>=")))
|
||||
(production :punctuator (#\> #\> #\>) punctuator-logical-right-shift (lex (tag punctuator ">>>")))
|
||||
(production :punctuator (#\> #\> #\> #\=) punctuator-logical-right-shift-equals (lex (tag punctuator ">>>=")))
|
||||
(production :punctuator (#\?) punctuator-question (lex (tag punctuator "?")))
|
||||
(production :punctuator (#\@) punctuator-at (lex (tag punctuator "@")))
|
||||
(production :punctuator (#\[) punctuator-open-bracket (lex (tag punctuator "[")))
|
||||
(production :punctuator (#\]) punctuator-close-bracket (lex (tag punctuator "]")))
|
||||
(production :punctuator (#\^) punctuator-xor (lex (tag punctuator "^")))
|
||||
(production :punctuator (#\^ #\=) punctuator-xor-equals (lex (tag punctuator "^=")))
|
||||
(production :punctuator (#\^ #\^) punctuator-logical-xor (lex (tag punctuator "^^")))
|
||||
(production :punctuator (#\^ #\^ #\=) punctuator-logical-xor-equals (lex (tag punctuator "^^=")))
|
||||
(production :punctuator (#\{) punctuator-open-brace (lex (tag punctuator "{")))
|
||||
(production :punctuator (#\|) punctuator-or (lex (tag punctuator "|")))
|
||||
(production :punctuator (#\| #\=) punctuator-or-equals (lex (tag punctuator "|=")))
|
||||
(production :punctuator (#\| #\|) punctuator-logical-or (lex (tag punctuator "||")))
|
||||
(production :punctuator (#\| #\| #\=) punctuator-logical-or-equals (lex (tag punctuator "||=")))
|
||||
(production :punctuator (#\}) punctuator-close-brace (lex (tag punctuator "}")))
|
||||
(production :punctuator (#\~) punctuator-complement (lex (tag punctuator "~"))))
|
||||
(production :punctuator (#\!) punctuator-not (lex (new punctuator "!")))
|
||||
(production :punctuator (#\! #\=) punctuator-not-equal (lex (new punctuator "!=")))
|
||||
(production :punctuator (#\! #\= #\=) punctuator-not-identical (lex (new punctuator "!==")))
|
||||
(production :punctuator (#\#) punctuator-hash (lex (new punctuator "#")))
|
||||
(production :punctuator (#\%) punctuator-modulo (lex (new punctuator "%")))
|
||||
(production :punctuator (#\% #\=) punctuator-modulo-equals (lex (new punctuator "%=")))
|
||||
(production :punctuator (#\&) punctuator-and (lex (new punctuator "&")))
|
||||
(production :punctuator (#\& #\&) punctuator-logical-and (lex (new punctuator "&&")))
|
||||
(production :punctuator (#\& #\& #\=) punctuator-logical-and-equals (lex (new punctuator "&&=")))
|
||||
(production :punctuator (#\& #\=) punctuator-and-equals (lex (new punctuator "&=")))
|
||||
(production :punctuator (#\() punctuator-open-parenthesis (lex (new punctuator "(")))
|
||||
(production :punctuator (#\)) punctuator-close-parenthesis (lex (new punctuator ")")))
|
||||
(production :punctuator (#\*) punctuator-times (lex (new punctuator "*")))
|
||||
(production :punctuator (#\* #\=) punctuator-times-equals (lex (new punctuator "*=")))
|
||||
(production :punctuator (#\+) punctuator-plus (lex (new punctuator "+")))
|
||||
(production :punctuator (#\+ #\+) punctuator-increment (lex (new punctuator "++")))
|
||||
(production :punctuator (#\+ #\=) punctuator-plus-equals (lex (new punctuator "+=")))
|
||||
(production :punctuator (#\,) punctuator-comma (lex (new punctuator ",")))
|
||||
(production :punctuator (#\-) punctuator-minus (lex (new punctuator "-")))
|
||||
(production :punctuator (#\- #\-) punctuator-decrement (lex (new punctuator "--")))
|
||||
(production :punctuator (#\- #\=) punctuator-minus-equals (lex (new punctuator "-=")))
|
||||
(production :punctuator (#\- #\>) punctuator-arrow (lex (new punctuator "->")))
|
||||
(production :punctuator (#\.) punctuator-dot (lex (new punctuator ".")))
|
||||
(production :punctuator (#\. #\.) punctuator-double-dot (lex (new punctuator "..")))
|
||||
(production :punctuator (#\. #\. #\.) punctuator-triple-dot (lex (new punctuator "...")))
|
||||
(production :punctuator (#\:) punctuator-colon (lex (new punctuator ":")))
|
||||
(production :punctuator (#\: #\:) punctuator-namespace (lex (new punctuator "::")))
|
||||
(production :punctuator (#\;) punctuator-semicolon (lex (new punctuator ";")))
|
||||
(production :punctuator (#\<) punctuator-less-than (lex (new punctuator "<")))
|
||||
(production :punctuator (#\< #\<) punctuator-left-shift (lex (new punctuator "<<")))
|
||||
(production :punctuator (#\< #\< #\=) punctuator-left-shift-equals (lex (new punctuator "<<=")))
|
||||
(production :punctuator (#\< #\=) punctuator-less-than-or-equal (lex (new punctuator "<=")))
|
||||
(production :punctuator (#\=) punctuator-assignment (lex (new punctuator "=")))
|
||||
(production :punctuator (#\= #\=) punctuator-equal (lex (new punctuator "==")))
|
||||
(production :punctuator (#\= #\= #\=) punctuator-identical (lex (new punctuator "===")))
|
||||
(production :punctuator (#\>) punctuator-greater-than (lex (new punctuator ">")))
|
||||
(production :punctuator (#\> #\=) punctuator-greater-than-or-equal (lex (new punctuator ">=")))
|
||||
(production :punctuator (#\> #\>) punctuator-right-shift (lex (new punctuator ">>")))
|
||||
(production :punctuator (#\> #\> #\=) punctuator-right-shift-equals (lex (new punctuator ">>=")))
|
||||
(production :punctuator (#\> #\> #\>) punctuator-logical-right-shift (lex (new punctuator ">>>")))
|
||||
(production :punctuator (#\> #\> #\> #\=) punctuator-logical-right-shift-equals (lex (new punctuator ">>>=")))
|
||||
(production :punctuator (#\?) punctuator-question (lex (new punctuator "?")))
|
||||
(production :punctuator (#\@) punctuator-at (lex (new punctuator "@")))
|
||||
(production :punctuator (#\[) punctuator-open-bracket (lex (new punctuator "[")))
|
||||
(production :punctuator (#\]) punctuator-close-bracket (lex (new punctuator "]")))
|
||||
(production :punctuator (#\^) punctuator-xor (lex (new punctuator "^")))
|
||||
(production :punctuator (#\^ #\=) punctuator-xor-equals (lex (new punctuator "^=")))
|
||||
(production :punctuator (#\^ #\^) punctuator-logical-xor (lex (new punctuator "^^")))
|
||||
(production :punctuator (#\^ #\^ #\=) punctuator-logical-xor-equals (lex (new punctuator "^^=")))
|
||||
(production :punctuator (#\{) punctuator-open-brace (lex (new punctuator "{")))
|
||||
(production :punctuator (#\|) punctuator-or (lex (new punctuator "|")))
|
||||
(production :punctuator (#\| #\=) punctuator-or-equals (lex (new punctuator "|=")))
|
||||
(production :punctuator (#\| #\|) punctuator-logical-or (lex (new punctuator "||")))
|
||||
(production :punctuator (#\| #\| #\=) punctuator-logical-or-equals (lex (new punctuator "||=")))
|
||||
(production :punctuator (#\}) punctuator-close-brace (lex (new punctuator "}")))
|
||||
(production :punctuator (#\~) punctuator-complement (lex (new punctuator "~"))))
|
||||
|
||||
(rule :division-punctuator ((lex token))
|
||||
(production :division-punctuator (#\/ (:- #\/ #\*)) punctuator-divide (lex (tag punctuator "/")))
|
||||
(production :division-punctuator (#\/ #\=) punctuator-divide-equals (lex (tag punctuator "/="))))
|
||||
(production :division-punctuator (#\/ (:- #\/ #\*)) punctuator-divide (lex (new punctuator "/")))
|
||||
(production :division-punctuator (#\/ #\=) punctuator-divide-equals (lex (new punctuator "/="))))
|
||||
(%print-actions)
|
||||
|
||||
(%section "Numeric literals")
|
||||
|
||||
(rule :numeric-literal ((lex token))
|
||||
(production :numeric-literal (:decimal-literal) numeric-literal-decimal
|
||||
(lex (tag number (real-to-float64 (lex-number :decimal-literal)))))
|
||||
(lex (new number (real-to-float64 (lex-number :decimal-literal)))))
|
||||
(production :numeric-literal (:hex-integer-literal (:- :hex-digit)) numeric-literal-hex
|
||||
(lex (tag number (real-to-float64 (lex-number :hex-integer-literal))))))
|
||||
(lex (new number (real-to-float64 (lex-number :hex-integer-literal))))))
|
||||
(%print-actions)
|
||||
|
||||
(rule :decimal-literal ((lex-number rational))
|
||||
@ -408,9 +407,9 @@
|
||||
(grammar-argument :theta single double)
|
||||
(rule :string-literal ((lex token))
|
||||
(production :string-literal (#\' (:string-chars single) #\') string-literal-single
|
||||
(lex (tag string (lex-string :string-chars))))
|
||||
(lex (lex-string :string-chars)))
|
||||
(production :string-literal (#\" (:string-chars double) #\") string-literal-double
|
||||
(lex (tag string (lex-string :string-chars)))))
|
||||
(lex (lex-string :string-chars))))
|
||||
(%print-actions)
|
||||
|
||||
(rule (:string-chars :theta) ((lex-string string))
|
||||
@ -474,7 +473,7 @@
|
||||
|
||||
(rule :reg-exp-literal ((lex token))
|
||||
(production :reg-exp-literal (:reg-exp-body :reg-exp-flags) reg-exp-literal
|
||||
(lex (tag regular-expression (lex-string :reg-exp-body) (lex-string :reg-exp-flags)))))
|
||||
(lex (new regular-expression (lex-string :reg-exp-body) (lex-string :reg-exp-flags)))))
|
||||
|
||||
(rule :reg-exp-flags ((lex-string string))
|
||||
(production :reg-exp-flags () reg-exp-flags-none
|
||||
|
||||
@ -18,11 +18,11 @@
|
||||
(deftag argument-mismatch-error)
|
||||
(deftype semantic-error (tag syntax-error reference-error type-error property-not-found-error argument-mismatch-error))
|
||||
|
||||
(deftag go-break (value object) (label string))
|
||||
(deftag go-continue (value object) (label string))
|
||||
(deftag go-return (value object))
|
||||
(deftag go-throw (value object))
|
||||
(deftype early-exit (tag go-break go-continue go-return go-throw))
|
||||
(deftuple go-break (value object) (label string))
|
||||
(deftuple go-continue (value object) (label string))
|
||||
(deftuple go-return (value object))
|
||||
(deftuple go-throw (value object))
|
||||
(deftype early-exit (union go-break go-continue go-return go-throw))
|
||||
|
||||
(deftype semantic-exception (union early-exit semantic-error))
|
||||
|
||||
@ -39,10 +39,9 @@
|
||||
|
||||
(%subsection :semantics "Namespaces")
|
||||
(defrecord namespace (name string))
|
||||
(deftype namespace (tag namespace))
|
||||
(deftype namespace-opt (union null namespace))
|
||||
|
||||
(define public-namespace namespace (tag namespace "public"))
|
||||
(define public-namespace namespace (new namespace "public"))
|
||||
|
||||
|
||||
(%subsection :semantics "Attributes")
|
||||
@ -62,8 +61,8 @@
|
||||
(deftag override)
|
||||
(deftype override-modifier (tag null may-override override))
|
||||
|
||||
(deftag attribute
|
||||
(namespaces (vector namespace)) ;***** Should be a set of namespaces
|
||||
(deftuple attribute
|
||||
(namespaces (list-set namespace))
|
||||
(local boolean)
|
||||
(extend class-opt)
|
||||
(enumerable boolean)
|
||||
@ -72,36 +71,33 @@
|
||||
(override-mod override-modifier)
|
||||
(prototype boolean)
|
||||
(unused boolean))
|
||||
(deftype attribute (tag attribute))
|
||||
|
||||
|
||||
(%subsection :semantics "Classes")
|
||||
(%text :comment "The first " (:type object) " is the this value, the " (:type (vector object)) " are the positional arguments, and the "
|
||||
(:type (vector named-argument)) " are the named arguments.")
|
||||
(deftype invoker (-> (object (vector object) (vector named-argument)) object))
|
||||
(:type (list-set named-argument)) " are the named arguments.")
|
||||
(deftype invoker (-> (object (vector object) (list-set named-argument)) object))
|
||||
|
||||
(defrecord class
|
||||
(super class-opt)
|
||||
(prototype object)
|
||||
(global-members (vector global-member) :var)
|
||||
(instance-members (vector instance-member) :var)
|
||||
(definition-namespaces (vector namespace))
|
||||
(global-members (list-set global-member) :var)
|
||||
(instance-members (list-set instance-member) :var)
|
||||
(class-mod class-modifier)
|
||||
(primitive boolean)
|
||||
(private-namespace namespace)
|
||||
(call invoker)
|
||||
(construct invoker))
|
||||
(deftype class (tag class))
|
||||
(deftype class-opt (union null class))
|
||||
|
||||
(define (make-built-in-class (superclass class-opt) (class-mod class-modifier) (primitive boolean)) class
|
||||
(const private-namespace namespace (tag namespace "private"))
|
||||
(function (call (this object :unused) (positional-args (vector object) :unused) (named-args (vector named-argument) :unused)) object
|
||||
(const private-namespace namespace (new namespace "private"))
|
||||
(function (call (this object :unused) (positional-args (vector object) :unused) (named-args (list-set named-argument) :unused)) object
|
||||
(todo))
|
||||
(function (construct (this object :unused) (positional-args (vector object) :unused) (named-args (vector named-argument) :unused)) object
|
||||
(function (construct (this object :unused) (positional-args (vector object) :unused) (named-args (list-set named-argument) :unused)) object
|
||||
(todo))
|
||||
(return (tag class superclass null (vector-of global-member) (vector-of instance-member)
|
||||
(vector private-namespace) class-mod primitive private-namespace call construct)))
|
||||
(return (new class superclass null (list-set-of global-member) (list-set-of instance-member)
|
||||
class-mod primitive private-namespace call construct)))
|
||||
|
||||
(define object-class class (make-built-in-class null dynamic true))
|
||||
(define undefined-class class (make-built-in-class object-class fixed true))
|
||||
@ -118,7 +114,7 @@
|
||||
(%text :comment "Return an ordered list of class " (:local d) :apostrophe "s ancestors, including " (:local d) " itself.")
|
||||
(define (ancestors (c class)) (vector class)
|
||||
(const s class-opt (& super c))
|
||||
(if (:narrow-false (in (tag null) s))
|
||||
(if (in s (tag null) :narrow-false)
|
||||
(return (vector c))
|
||||
(return (append (ancestors s) (vector c)))))
|
||||
|
||||
@ -127,7 +123,7 @@
|
||||
(cond
|
||||
((= c d class) (return true))
|
||||
(nil (const s class-opt (& super d))
|
||||
(rwhen (:narrow-false (in (tag null) s))
|
||||
(rwhen (in s (tag null) :narrow-false)
|
||||
(return false))
|
||||
(return (is-ancestor c s)))))
|
||||
|
||||
@ -137,10 +133,9 @@
|
||||
|
||||
|
||||
(%subsection :semantics "Method Closures")
|
||||
(deftag method-closure
|
||||
(deftuple method-closure
|
||||
(this object)
|
||||
(method method))
|
||||
(deftype method-closure (tag method-closure))
|
||||
|
||||
|
||||
(%subsection :semantics "General Instances")
|
||||
@ -150,15 +145,13 @@
|
||||
(call invoker)
|
||||
(construct invoker)
|
||||
(typeof-string string)
|
||||
(slots (vector slot) :var)
|
||||
(dynamic-properties (vector dynamic-property) :var))
|
||||
(deftype instance (tag instance))
|
||||
(slots (list-set slot) :var)
|
||||
(dynamic-properties (list-set dynamic-property) :var))
|
||||
(deftype instance-opt (union null instance))
|
||||
|
||||
(defrecord dynamic-property
|
||||
(name string)
|
||||
(value object))
|
||||
(deftype dynamic-property (tag dynamic-property))
|
||||
|
||||
|
||||
(%subsection :semantics "Objects")
|
||||
@ -201,7 +194,7 @@
|
||||
(case o
|
||||
(:select (union undefined null) (return false))
|
||||
(:narrow boolean (return o))
|
||||
(:narrow float64 (return (not-in (tag +zero -zero nan) o)))
|
||||
(:narrow float64 (return (not-in o (tag +zero -zero nan))))
|
||||
(:narrow string (return (/= o "" string)))
|
||||
(:select (union namespace attribute class method-closure) (return true))
|
||||
(:select instance (todo))))
|
||||
@ -241,7 +234,7 @@
|
||||
(return (- i (expt 2 32)))))
|
||||
|
||||
(define (to-u-int32 (x float64)) integer
|
||||
(rwhen (:narrow-false (in (tag +infinity -infinity nan) x))
|
||||
(rwhen (in x (tag +infinity -infinity nan) :narrow-false)
|
||||
(return 0))
|
||||
(return (mod (truncate-finite-float64 x) (expt 2 32))))
|
||||
|
||||
@ -269,133 +262,110 @@
|
||||
|
||||
(%subsection :semantics "Slots")
|
||||
(defrecord slot-id (type class))
|
||||
(deftype slot-id (tag slot-id))
|
||||
|
||||
(defrecord slot
|
||||
(id slot-id)
|
||||
(value object :var))
|
||||
(deftype slot (tag slot))
|
||||
|
||||
(define (find-slot (o object) (id slot-id)) slot
|
||||
(rwhen (:narrow-false (not-in instance o))
|
||||
(rwhen (not-in o instance :narrow-false)
|
||||
(bottom))
|
||||
(const matching-slots (vector slot)
|
||||
(const matching-slots (list-set slot)
|
||||
(map (& slots o) s s (= (& id s) id slot-id)))
|
||||
(assert (= (length matching-slots) 1))
|
||||
(return (nth matching-slots 0)))
|
||||
(return (elt-of matching-slots)))
|
||||
|
||||
(defrecord global-slot
|
||||
(type class)
|
||||
(value object :var))
|
||||
(deftype global-slot (tag global-slot))
|
||||
|
||||
|
||||
(%subsection :semantics "Signatures")
|
||||
(deftag signature
|
||||
(deftuple signature
|
||||
(required-positional (vector class))
|
||||
(optional-positional (vector class))
|
||||
(required-named (vector named-parameter))
|
||||
(optional-named (vector named-parameter))
|
||||
(optional-named (list-set named-parameter))
|
||||
(rest class-opt)
|
||||
(rest-allows-names boolean)
|
||||
(return-type class))
|
||||
(deftype signature (tag signature))
|
||||
|
||||
(deftag named-parameter
|
||||
(deftuple named-parameter
|
||||
(name string)
|
||||
(type class))
|
||||
(deftype named-parameter (tag named-parameter))
|
||||
|
||||
|
||||
(%subsection :semantics "Members")
|
||||
(defrecord method
|
||||
(type signature)
|
||||
(f instance-opt)) ;Method code (may be undefined)
|
||||
(deftype method (tag method))
|
||||
|
||||
(defrecord accessor
|
||||
(type class)
|
||||
(f instance)) ;Getter or setter function code
|
||||
(deftype accessor (tag accessor))
|
||||
|
||||
(deftype instance-category (tag abstract virtual final))
|
||||
(deftype instance-data (union slot-id method accessor))
|
||||
|
||||
(defrecord instance-member
|
||||
(name string)
|
||||
(namespaces (vector namespace))
|
||||
(namespaces (list-set namespace))
|
||||
(category instance-category)
|
||||
(readable boolean)
|
||||
(writable boolean)
|
||||
(indexable boolean)
|
||||
(enumerable boolean)
|
||||
(data (union instance-data namespace)))
|
||||
(deftype instance-member (tag instance-member))
|
||||
|
||||
(deftype global-category (tag static constructor))
|
||||
(deftype global-data (union global-slot method accessor))
|
||||
|
||||
(defrecord global-member
|
||||
(name string)
|
||||
(namespaces (vector namespace))
|
||||
(namespaces (list-set namespace))
|
||||
(category global-category)
|
||||
(readable boolean)
|
||||
(writable boolean)
|
||||
(indexable boolean)
|
||||
(enumerable boolean)
|
||||
(data (union global-data namespace)))
|
||||
(deftype global-member (tag global-member))
|
||||
(deftype member (union instance-member global-member))
|
||||
(deftype member-data (union instance-data global-data))
|
||||
(deftype member-data-opt (union null member-data))
|
||||
|
||||
(deftag qualified-name (namespace namespace) (name string))
|
||||
(deftype qualified-name (tag qualified-name))
|
||||
(deftuple qualified-name (namespace namespace) (name string))
|
||||
|
||||
|
||||
(define (most-specific-member (c class) (global boolean) (name string) (ns namespace) (indexable-only boolean)) member-data-opt
|
||||
(function (test (m member)) boolean
|
||||
(return (and (& readable m)
|
||||
(= name (& name m) string)
|
||||
(namespace-in (& namespaces m) ns)
|
||||
(set-in ns (& namespaces m))
|
||||
(or (not indexable-only) (& indexable m)))))
|
||||
(var ns2 namespace ns)
|
||||
(var members (vector member) (& instance-members c))
|
||||
(when global
|
||||
(<- members (& global-members c)))
|
||||
(const matches (vector member) (map members m m (test m)))
|
||||
(const members (list-set member) (if global (& global-members c) (& instance-members c)))
|
||||
(const matches (list-set member) (map members m m (test m)))
|
||||
(when (nonempty matches)
|
||||
(assert (= (length matches) 1))
|
||||
(const d (union member-data namespace) (& data (nth matches 0)))
|
||||
(rwhen (:narrow-both (not-in namespace d))
|
||||
(const d (union member-data namespace) (& data (elt-of matches)))
|
||||
(rwhen (not-in d namespace :narrow-both)
|
||||
(return d))
|
||||
(<- ns2 d))
|
||||
(const s class-opt (& super c))
|
||||
(rwhen (:narrow-true (not-in (tag null) s))
|
||||
(rwhen (not-in s (tag null) :narrow-true)
|
||||
(return (most-specific-member s global name ns2 indexable-only)))
|
||||
(return null))
|
||||
|
||||
(%text :comment "Temporary hack until I get sets of namespaces working")
|
||||
(define (namespace-in (v (vector namespace)) (ns namespace)) boolean
|
||||
(const d (vector namespace) (map v n n (= n ns namespace)))
|
||||
(return (nonempty d)))
|
||||
|
||||
(define (namespace-intersection (v (vector namespace) :unused) (w (vector namespace) :unused)) (vector namespace)
|
||||
(todo))
|
||||
|
||||
(define (read-qualified-property (o object) (name string) (ns namespace) (indexable-only boolean)) object
|
||||
(when (:narrow-true (in instance o))
|
||||
(when (= ns public-namespace namespace)
|
||||
(const d (vector dynamic-property) (map (& dynamic-properties o) p p (= name (& name p) string)))
|
||||
(rwhen (nonempty d)
|
||||
(assert (= (length d) 1))
|
||||
(return (& value (nth d 0)))))
|
||||
(rwhen (not-in (tag null) (& model o))
|
||||
(when (in o instance :narrow-true)
|
||||
(reserve p)
|
||||
(rwhen (and (= ns public-namespace namespace)
|
||||
(some (& dynamic-properties o) p (= name (& name p) string) :define-true))
|
||||
(return (& value p)))
|
||||
(rwhen (not-in (& model o) (tag null))
|
||||
(return (read-qualified-property (& model o) name ns indexable-only))))
|
||||
(var d member-data-opt null)
|
||||
(if (:narrow-true (in class o))
|
||||
(<- d (most-specific-member o true name ns indexable-only))
|
||||
(<- d (most-specific-member (object-type o) false name ns indexable-only)))
|
||||
(const d member-data-opt (if (in o class :narrow-true)
|
||||
(most-specific-member o true name ns indexable-only)
|
||||
(most-specific-member (object-type o) false name ns indexable-only)))
|
||||
(case d
|
||||
(:select (tag null)
|
||||
(rwhen (= (& class-mod (object-type o)) dynamic class-modifier)
|
||||
@ -404,44 +374,41 @@
|
||||
(:narrow global-slot (return (& value d)))
|
||||
(:narrow slot-id (return (& value (find-slot o d))))
|
||||
(:narrow method
|
||||
(return (tag method-closure o d)))
|
||||
(return (new method-closure o d)))
|
||||
(:narrow accessor
|
||||
(return ((& call (& f d)) o (vector-of object) (vector-of named-argument))))))
|
||||
(return ((& call (& f d)) o (vector-of object) (list-set-of named-argument))))))
|
||||
|
||||
(define (resolve-member-namespace (c class) (global boolean) (name string) (uses (vector namespace))) namespace-opt
|
||||
(define (resolve-member-namespace (c class) (global boolean) (name string) (uses (list-set namespace))) namespace-opt
|
||||
(const s class-opt (& super c))
|
||||
(when (:narrow-true (not-in (tag null) s))
|
||||
(when (not-in s (tag null) :narrow-true)
|
||||
(const ns namespace-opt (resolve-member-namespace s global name uses))
|
||||
(rwhen (:narrow-true (not-in (tag null) ns))
|
||||
(rwhen (not-in ns (tag null) :narrow-true)
|
||||
(return ns)))
|
||||
(function (test (m member)) boolean
|
||||
(return (and (& readable m)
|
||||
(= name (& name m) string)
|
||||
(nonempty (namespace-intersection uses (& namespaces m))))))
|
||||
(var members (vector member) (& instance-members c))
|
||||
(when global
|
||||
(<- members (& global-members c)))
|
||||
(const matches (vector member) (map members m m (test m)))
|
||||
(nonempty (set* uses (& namespaces m))))))
|
||||
(const members (list-set member) (if global (& global-members c) (& instance-members c)))
|
||||
(const matches (list-set member) (map members m m (test m)))
|
||||
(rwhen (nonempty matches)
|
||||
(rwhen (> (length matches) 1)
|
||||
(throw property-not-found-error))
|
||||
(const matching-namespaces (vector namespace) (namespace-intersection uses (& namespaces (nth matches 0))))
|
||||
(return (nth matching-namespaces 0)))
|
||||
(const matching-namespaces (list-set namespace) (set* uses (& namespaces (elt-of matches))))
|
||||
(return (elt-of matching-namespaces)))
|
||||
(return null))
|
||||
|
||||
(define (resolve-object-namespace (o object) (name string) (uses (vector namespace))) namespace
|
||||
(when (:narrow-true (in instance o))
|
||||
(rwhen (not-in (tag null) (& model o))
|
||||
(define (resolve-object-namespace (o object) (name string) (uses (list-set namespace))) namespace
|
||||
(when (in o instance :narrow-true)
|
||||
(rwhen (not-in (& model o) (tag null))
|
||||
(return (resolve-object-namespace (& model o) name uses))))
|
||||
(var ns namespace-opt null)
|
||||
(if (:narrow-true (in class o))
|
||||
(<- ns (resolve-member-namespace o true name uses))
|
||||
(<- ns (resolve-member-namespace (object-type o) false name uses)))
|
||||
(rwhen (:narrow-true (not-in (tag null) ns))
|
||||
(const ns namespace-opt (if (in o class :narrow-true)
|
||||
(resolve-member-namespace o true name uses)
|
||||
(resolve-member-namespace (object-type o) false name uses)))
|
||||
(rwhen (not-in ns (tag null) :narrow-true)
|
||||
(return ns))
|
||||
(return public-namespace))
|
||||
|
||||
(define (read-unqualified-property (o object) (name string) (uses (vector namespace))) object
|
||||
(define (read-unqualified-property (o object) (name string) (uses (list-set namespace))) object
|
||||
(const ns namespace (resolve-object-namespace o name uses))
|
||||
(return (read-qualified-property o name ns false)))
|
||||
|
||||
@ -453,18 +420,17 @@
|
||||
|
||||
|
||||
(%subsection :semantics "Verification Environments")
|
||||
(deftag verify-env
|
||||
(deftuple verify-env
|
||||
(enclosing-class class-opt)
|
||||
(labels (vector string))
|
||||
(can-return boolean)
|
||||
(constants (vector definition)))
|
||||
(deftype verify-env (tag verify-env))
|
||||
|
||||
(define initial-verify-env verify-env (tag verify-env null (vector-of string) false (vector-of definition)))
|
||||
(define initial-verify-env verify-env (new verify-env null (vector-of string) false (vector-of definition)))
|
||||
|
||||
(%text :comment "Return a " (:type verify-env) " with label " (:local label) " prepended to " (:local s) ".")
|
||||
(define (add-label (t verify-env) (label string)) verify-env
|
||||
(return (tag verify-env (& enclosing-class t) (append (vector label) (& labels t)) (& can-return t) (& constants t))))
|
||||
(return (new verify-env (& enclosing-class t) (append (vector label) (& labels t)) (& can-return t) (& constants t))))
|
||||
|
||||
(%text :comment "Return " (:tag true) " if this code is inside a class body.")
|
||||
(define (inside-class (s verify-env)) boolean
|
||||
@ -479,23 +445,21 @@
|
||||
(reader-passthroughs (vector qualified-name) :var)
|
||||
(writer-definitions (vector definition) :var)
|
||||
(writer-passthroughs (vector qualified-name) :var))
|
||||
(deftype dynamic-env (tag dynamic-env))
|
||||
(deftype dynamic-env-opt (union null dynamic-env))
|
||||
|
||||
(%text :comment "If the " (:type dynamic-env) " is from within a class" :apostrophe "s body, return that class; otherwise, return " (:tag null) ".")
|
||||
(define (lexical-class (e dynamic-env :unused)) class-opt
|
||||
(todo))
|
||||
|
||||
(define initial-dynamic-env dynamic-env (tag dynamic-env null null
|
||||
(define initial-dynamic-env dynamic-env (new dynamic-env null null
|
||||
(vector-of definition) (vector-of qualified-name)
|
||||
(vector-of definition) (vector-of qualified-name)))
|
||||
|
||||
|
||||
(deftag definition
|
||||
(deftuple definition
|
||||
(name qualified-name)
|
||||
(type class)
|
||||
(data (union slot object accessor)))
|
||||
(deftype definition (tag definition))
|
||||
|
||||
|
||||
(define (lookup-variable (e dynamic-env :unused) (name string :unused) (internal-is-namespace boolean :unused)) reference
|
||||
@ -506,23 +470,20 @@
|
||||
|
||||
|
||||
(%subsection :semantics "Unary Operators")
|
||||
(deftag named-argument (name string) (value object))
|
||||
(deftype named-argument (tag named-argument))
|
||||
(deftuple named-argument (name string) (value object))
|
||||
|
||||
(deftag unary-method
|
||||
(deftuple unary-method
|
||||
(operand-type class)
|
||||
(op (-> (object object (vector object) (vector named-argument)) object)))
|
||||
(deftype unary-method (tag unary-method))
|
||||
(op (-> (object object (vector object) (list-set named-argument)) object)))
|
||||
|
||||
(defrecord unary-table
|
||||
(methods (vector unary-method) :var))
|
||||
(deftype unary-table (tag unary-table))
|
||||
(methods (list-set unary-method) :var))
|
||||
|
||||
(%text :comment "Return " (:tag true) " if " (:local v) " is a member of class " (:local c) " and, if "
|
||||
(:local limit) " is non-" (:tag null) ", " (:local c) " is a proper ancestor of " (:local limit) ".")
|
||||
(define (limited-instance-of (v object) (c class) (limit class-opt)) boolean
|
||||
(if (instance-of v c)
|
||||
(if (:narrow-false (in (tag null) limit))
|
||||
(if (in limit (tag null) :narrow-false)
|
||||
(return true)
|
||||
(return (is-proper-ancestor c limit)))
|
||||
(return false)))
|
||||
@ -530,103 +491,99 @@
|
||||
(%text :comment "Dispatch the unary operator described by " (:local table) " applied to the " (:character-literal "this")
|
||||
" value " (:local this) ", the first argument " (:local op)
|
||||
", a vector of zero or more additional positional arguments " (:local positional-args)
|
||||
", and a vector of zero or more named arguments " (:local named-args)
|
||||
", and a set of zero or more named arguments " (:local named-args)
|
||||
". If " (:local limit) " is non-" (:tag null)
|
||||
", restrict the lookup to operators defined on the proper ancestors of " (:local limit) ".")
|
||||
(define (unary-dispatch (table unary-table) (limit class-opt) (this object) (op object) (positional-args (vector object))
|
||||
(named-args (vector named-argument))) object
|
||||
(const applicable-ops (vector unary-method)
|
||||
(named-args (list-set named-argument))) object
|
||||
(const applicable-ops (list-set unary-method)
|
||||
(map (& methods table) m m (limited-instance-of op (& operand-type m) limit)))
|
||||
(const best-ops (vector unary-method)
|
||||
(map applicable-ops m m
|
||||
(empty (map applicable-ops m2 m2 (not (is-ancestor (& operand-type m2) (& operand-type m)))))))
|
||||
(rwhen (empty best-ops)
|
||||
(throw property-not-found-error))
|
||||
(assert (= (length best-ops) 1))
|
||||
(return ((& op (nth best-ops 0)) this op positional-args named-args)))
|
||||
(reserve best)
|
||||
(if (some applicable-ops best
|
||||
(every applicable-ops m2 (is-ancestor (& operand-type m2) (& operand-type best))) :define-true)
|
||||
(return ((& op best) this op positional-args named-args))
|
||||
(throw property-not-found-error)))
|
||||
|
||||
|
||||
(%subsection :semantics "Unary Operator Tables")
|
||||
|
||||
(define (plus-object (this object :unused) (a object) (positional-args (vector object) :unused) (named-args (vector named-argument) :unused)) object
|
||||
(define (plus-object (this object :unused) (a object) (positional-args (vector object) :unused) (named-args (list-set named-argument) :unused)) object
|
||||
(return (to-number a)))
|
||||
|
||||
(define (minus-object (this object :unused) (a object) (positional-args (vector object) :unused) (named-args (vector named-argument) :unused)) object
|
||||
(define (minus-object (this object :unused) (a object) (positional-args (vector object) :unused) (named-args (list-set named-argument) :unused)) object
|
||||
(return (float64-negate (to-number a))))
|
||||
|
||||
(define (bitwise-not-object (this object :unused) (a object) (positional-args (vector object) :unused) (named-args (vector named-argument) :unused)) object
|
||||
(define (bitwise-not-object (this object :unused) (a object) (positional-args (vector object) :unused) (named-args (list-set named-argument) :unused)) object
|
||||
(const i integer (to-int32 (to-number a)))
|
||||
(return (real-to-float64 (bitwise-xor i -1))))
|
||||
|
||||
(define (increment-object (this object :unused) (a object) (positional-args (vector object) :unused) (named-args (vector named-argument) :unused)) object
|
||||
(define (increment-object (this object :unused) (a object) (positional-args (vector object) :unused) (named-args (list-set named-argument) :unused)) object
|
||||
(const x object (unary-plus a))
|
||||
(return (binary-dispatch add-table null null x 1.0)))
|
||||
|
||||
(define (decrement-object (this object :unused) (a object) (positional-args (vector object) :unused) (named-args (vector named-argument) :unused)) object
|
||||
(define (decrement-object (this object :unused) (a object) (positional-args (vector object) :unused) (named-args (list-set named-argument) :unused)) object
|
||||
(const x object (unary-plus a))
|
||||
(return (binary-dispatch subtract-table null null x 1.0)))
|
||||
|
||||
(define (call-object (this object) (a object) (positional-args (vector object)) (named-args (vector named-argument))) object
|
||||
(define (call-object (this object) (a object) (positional-args (vector object)) (named-args (list-set named-argument))) object
|
||||
(case a
|
||||
(:select (union undefined null boolean float64 string namespace attribute) (throw type-error))
|
||||
(:narrow (union class instance) (return ((& call a) this positional-args named-args)))
|
||||
(:narrow method-closure (return (call-object (& this a) (& f (& method a)) positional-args named-args)))))
|
||||
|
||||
(define (construct-object (this object) (a object) (positional-args (vector object)) (named-args (vector named-argument))) object
|
||||
(define (construct-object (this object) (a object) (positional-args (vector object)) (named-args (list-set named-argument))) object
|
||||
(case a
|
||||
(:select (union undefined null boolean float64 string namespace attribute method-closure) (throw type-error))
|
||||
(:narrow (union class instance) (return ((& construct a) this positional-args named-args)))))
|
||||
|
||||
(define (bracket-read-object (this object :unused) (a object) (positional-args (vector object)) (named-args (vector named-argument))) object
|
||||
(rwhen (or (/= (length positional-args) 1) (not (empty named-args)))
|
||||
(define (bracket-read-object (this object :unused) (a object) (positional-args (vector object)) (named-args (list-set named-argument))) object
|
||||
(rwhen (or (/= (length positional-args) 1) (nonempty named-args))
|
||||
(throw argument-mismatch-error))
|
||||
(const name string (to-string (nth positional-args 0)))
|
||||
(return (read-qualified-property a name public-namespace true)))
|
||||
|
||||
(define (bracket-write-object (this object :unused) (a object) (positional-args (vector object)) (named-args (vector named-argument))) object
|
||||
(rwhen (or (/= (length positional-args) 2) (not (empty named-args)))
|
||||
(define (bracket-write-object (this object :unused) (a object) (positional-args (vector object)) (named-args (list-set named-argument))) object
|
||||
(rwhen (or (/= (length positional-args) 2) (nonempty named-args))
|
||||
(throw argument-mismatch-error))
|
||||
(const new-value object (nth positional-args 0))
|
||||
(const name string (to-string (nth positional-args 1)))
|
||||
(write-qualified-property a name public-namespace true new-value)
|
||||
(return new-value))
|
||||
|
||||
(define (bracket-delete-object (this object :unused) (a object) (positional-args (vector object)) (named-args (vector named-argument))) object
|
||||
(rwhen (or (/= (length positional-args) 1) (not (empty named-args)))
|
||||
(define (bracket-delete-object (this object :unused) (a object) (positional-args (vector object)) (named-args (list-set named-argument))) object
|
||||
(rwhen (or (/= (length positional-args) 1) (nonempty named-args))
|
||||
(throw argument-mismatch-error))
|
||||
(const name string (to-string (nth positional-args 0)))
|
||||
(return (delete-qualified-property a name public-namespace true)))
|
||||
|
||||
|
||||
(define plus-table unary-table (tag unary-table (vector (tag unary-method object-class plus-object))))
|
||||
(define minus-table unary-table (tag unary-table (vector (tag unary-method object-class minus-object))))
|
||||
(define bitwise-not-table unary-table (tag unary-table (vector (tag unary-method object-class bitwise-not-object))))
|
||||
(define increment-table unary-table (tag unary-table (vector (tag unary-method object-class increment-object))))
|
||||
(define decrement-table unary-table (tag unary-table (vector (tag unary-method object-class decrement-object))))
|
||||
(define call-table unary-table (tag unary-table (vector (tag unary-method object-class call-object))))
|
||||
(define construct-table unary-table (tag unary-table (vector (tag unary-method object-class construct-object))))
|
||||
(define bracket-read-table unary-table (tag unary-table (vector (tag unary-method object-class bracket-read-object))))
|
||||
(define bracket-write-table unary-table (tag unary-table (vector (tag unary-method object-class bracket-write-object))))
|
||||
(define bracket-delete-table unary-table (tag unary-table (vector (tag unary-method object-class bracket-delete-object))))
|
||||
(define plus-table unary-table (new unary-table (list-set (new unary-method object-class plus-object))))
|
||||
(define minus-table unary-table (new unary-table (list-set (new unary-method object-class minus-object))))
|
||||
(define bitwise-not-table unary-table (new unary-table (list-set (new unary-method object-class bitwise-not-object))))
|
||||
(define increment-table unary-table (new unary-table (list-set (new unary-method object-class increment-object))))
|
||||
(define decrement-table unary-table (new unary-table (list-set (new unary-method object-class decrement-object))))
|
||||
(define call-table unary-table (new unary-table (list-set (new unary-method object-class call-object))))
|
||||
(define construct-table unary-table (new unary-table (list-set (new unary-method object-class construct-object))))
|
||||
(define bracket-read-table unary-table (new unary-table (list-set (new unary-method object-class bracket-read-object))))
|
||||
(define bracket-write-table unary-table (new unary-table (list-set (new unary-method object-class bracket-write-object))))
|
||||
(define bracket-delete-table unary-table (new unary-table (list-set (new unary-method object-class bracket-delete-object))))
|
||||
|
||||
|
||||
(define (unary-plus (a object)) object
|
||||
(return (unary-dispatch plus-table null null a (vector-of object) (vector-of named-argument))))
|
||||
(return (unary-dispatch plus-table null null a (vector-of object) (list-set-of named-argument))))
|
||||
|
||||
(define (unary-not (a object)) object
|
||||
(return (not (to-boolean a))))
|
||||
|
||||
|
||||
(%subsection :semantics "Binary Operators")
|
||||
(deftag binary-method
|
||||
(deftuple binary-method
|
||||
(left-type class)
|
||||
(right-type class)
|
||||
(op (-> (object object) object)))
|
||||
(deftype binary-method (tag binary-method))
|
||||
|
||||
(defrecord binary-table
|
||||
(methods (vector binary-method) :var))
|
||||
(deftype binary-table (tag binary-table))
|
||||
(methods (list-set binary-method) :var))
|
||||
|
||||
|
||||
(%text :comment "Return " (:tag true) " if " (:local m1) " is at least as specific as " (:local m2) ".")
|
||||
@ -640,16 +597,14 @@
|
||||
" for the left operand. Similarly, if " (:local right-limit) " is non-" (:tag null)
|
||||
", restrict the lookup to operator definitions with an ancestor of " (:local right-limit) " for the right operand.")
|
||||
(define (binary-dispatch (table binary-table) (left-limit class-opt) (right-limit class-opt) (left object) (right object)) object
|
||||
(const applicable-ops (vector binary-method)
|
||||
(const applicable-ops (list-set binary-method)
|
||||
(map (& methods table) m m (and (limited-instance-of left (& left-type m) left-limit)
|
||||
(limited-instance-of right (& right-type m) right-limit))))
|
||||
(const best-ops (vector binary-method)
|
||||
(map applicable-ops m m
|
||||
(empty (map applicable-ops m2 m2 (not (is-binary-descendant m m2))))))
|
||||
(rwhen (empty best-ops)
|
||||
(throw property-not-found-error))
|
||||
(assert (= (length best-ops) 1))
|
||||
(return ((& op (nth best-ops 0)) left right)))
|
||||
(reserve best)
|
||||
(if (some applicable-ops best
|
||||
(every applicable-ops m2 (is-binary-descendant best m2)) :define-true)
|
||||
(return ((& op best) left right))
|
||||
(throw property-not-found-error)))
|
||||
|
||||
|
||||
(%subsection :semantics "Binary Operator Tables")
|
||||
@ -657,7 +612,7 @@
|
||||
(define (add-objects (a object) (b object)) object
|
||||
(const ap object (to-primitive a null))
|
||||
(const bp object (to-primitive b null))
|
||||
(if (or (in string ap) (in string bp))
|
||||
(if (or (in ap string) (in bp string))
|
||||
(return (append (to-string ap) (to-string bp)))
|
||||
(return (float64-add (to-number ap) (to-number bp)))))
|
||||
|
||||
@ -677,23 +632,23 @@
|
||||
(define (less-objects (a object) (b object)) object
|
||||
(const ap object (to-primitive a null))
|
||||
(const bp object (to-primitive b null))
|
||||
(if (:narrow-true (and (in string ap) (in string bp)))
|
||||
(if (and (in ap string :narrow-true) (in bp string :narrow-true))
|
||||
(return (< ap bp string))
|
||||
(return (= (float64-compare (to-number ap) (to-number bp)) less order))))
|
||||
|
||||
(define (less-or-equal-objects (a object) (b object)) object
|
||||
(const ap object (to-primitive a null))
|
||||
(const bp object (to-primitive b null))
|
||||
(if (:narrow-true (and (in string ap) (in string bp)))
|
||||
(if (and (in ap string :narrow-true) (in bp string :narrow-true))
|
||||
(return (<= ap bp string))
|
||||
(return (in (tag less equal) (float64-compare (to-number ap) (to-number bp))))))
|
||||
(return (in (float64-compare (to-number ap) (to-number bp)) (tag less equal)))))
|
||||
|
||||
(define (equal-objects (a object) (b object)) object
|
||||
(case a
|
||||
(:select (union undefined null)
|
||||
(return (in (union undefined null) b)))
|
||||
(return (in b (union undefined null))))
|
||||
(:narrow boolean
|
||||
(if (:narrow-true (in boolean b))
|
||||
(if (in b boolean :narrow-true)
|
||||
(return (= a b boolean))
|
||||
(return (equal-objects (to-number a) b))))
|
||||
(:narrow float64
|
||||
@ -718,7 +673,7 @@
|
||||
(:select (union boolean float64 string) (return (equal-objects ap b)))))))))
|
||||
|
||||
(define (strict-equal-objects (a object) (b object)) object
|
||||
(if (:narrow-true (and (in float64 a) (in float64 b)))
|
||||
(if (and (in a float64 :narrow-true) (in b float64 :narrow-true))
|
||||
(return (= (float64-compare a b) equal order))
|
||||
(return (= a b object))))
|
||||
|
||||
@ -754,21 +709,21 @@
|
||||
(return (real-to-float64 (bitwise-or i j))))
|
||||
|
||||
|
||||
(define add-table binary-table (tag binary-table (vector (tag binary-method object-class object-class add-objects))))
|
||||
(define subtract-table binary-table (tag binary-table (vector (tag binary-method object-class object-class subtract-objects))))
|
||||
(define multiply-table binary-table (tag binary-table (vector (tag binary-method object-class object-class multiply-objects))))
|
||||
(define divide-table binary-table (tag binary-table (vector (tag binary-method object-class object-class divide-objects))))
|
||||
(define remainder-table binary-table (tag binary-table (vector (tag binary-method object-class object-class remainder-objects))))
|
||||
(define less-table binary-table (tag binary-table (vector (tag binary-method object-class object-class less-objects))))
|
||||
(define less-or-equal-table binary-table (tag binary-table (vector (tag binary-method object-class object-class less-or-equal-objects))))
|
||||
(define equal-table binary-table (tag binary-table (vector (tag binary-method object-class object-class equal-objects))))
|
||||
(define strict-equal-table binary-table (tag binary-table (vector (tag binary-method object-class object-class strict-equal-objects))))
|
||||
(define shift-left-table binary-table (tag binary-table (vector (tag binary-method object-class object-class shift-left-objects))))
|
||||
(define shift-right-table binary-table (tag binary-table (vector (tag binary-method object-class object-class shift-right-objects))))
|
||||
(define shift-right-unsigned-table binary-table (tag binary-table (vector (tag binary-method object-class object-class shift-right-unsigned-objects))))
|
||||
(define bitwise-and-table binary-table (tag binary-table (vector (tag binary-method object-class object-class bitwise-and-objects))))
|
||||
(define bitwise-xor-table binary-table (tag binary-table (vector (tag binary-method object-class object-class bitwise-xor-objects))))
|
||||
(define bitwise-or-table binary-table (tag binary-table (vector (tag binary-method object-class object-class bitwise-or-objects))))
|
||||
(define add-table binary-table (new binary-table (list-set (new binary-method object-class object-class add-objects))))
|
||||
(define subtract-table binary-table (new binary-table (list-set (new binary-method object-class object-class subtract-objects))))
|
||||
(define multiply-table binary-table (new binary-table (list-set (new binary-method object-class object-class multiply-objects))))
|
||||
(define divide-table binary-table (new binary-table (list-set (new binary-method object-class object-class divide-objects))))
|
||||
(define remainder-table binary-table (new binary-table (list-set (new binary-method object-class object-class remainder-objects))))
|
||||
(define less-table binary-table (new binary-table (list-set (new binary-method object-class object-class less-objects))))
|
||||
(define less-or-equal-table binary-table (new binary-table (list-set (new binary-method object-class object-class less-or-equal-objects))))
|
||||
(define equal-table binary-table (new binary-table (list-set (new binary-method object-class object-class equal-objects))))
|
||||
(define strict-equal-table binary-table (new binary-table (list-set (new binary-method object-class object-class strict-equal-objects))))
|
||||
(define shift-left-table binary-table (new binary-table (list-set (new binary-method object-class object-class shift-left-objects))))
|
||||
(define shift-right-table binary-table (new binary-table (list-set (new binary-method object-class object-class shift-right-objects))))
|
||||
(define shift-right-unsigned-table binary-table (new binary-table (list-set (new binary-method object-class object-class shift-right-unsigned-objects))))
|
||||
(define bitwise-and-table binary-table (new binary-table (list-set (new binary-method object-class object-class bitwise-and-objects))))
|
||||
(define bitwise-xor-table binary-table (new binary-table (list-set (new binary-method object-class object-class bitwise-xor-objects))))
|
||||
(define bitwise-or-table binary-table (new binary-table (list-set (new binary-method object-class object-class bitwise-or-objects))))
|
||||
|
||||
|
||||
(%section "Terminal Actions")
|
||||
@ -801,7 +756,7 @@
|
||||
((verify (s :unused)) (todo))
|
||||
((eval e)
|
||||
(const a object (read-reference (lookup-variable e (name :identifier) true)))
|
||||
(rwhen (:narrow-false (not-in namespace a)) (throw type-error))
|
||||
(rwhen (not-in a namespace :narrow-false) (throw type-error))
|
||||
(return a)))
|
||||
(production :qualifier (public) qualifier-public
|
||||
((verify (s :unused)))
|
||||
@ -812,7 +767,7 @@
|
||||
(throw syntax-error)))
|
||||
((eval e)
|
||||
(const q class-opt (& enclosing-class e))
|
||||
(rwhen (:narrow-false (in null q)) (bottom))
|
||||
(rwhen (in q null :narrow-false) (bottom))
|
||||
(return (& private-namespace q)))))
|
||||
|
||||
(rule :simple-qualified-identifier ((verify (-> (verify-env) void)) (eval (-> (dynamic-env) reference)))
|
||||
@ -832,7 +787,7 @@
|
||||
(todo))
|
||||
((eval e)
|
||||
(const a object (read-reference ((eval :parenthesized-expression) e)))
|
||||
(rwhen (:narrow-false (not-in namespace a)) (throw type-error))
|
||||
(rwhen (not-in a namespace :narrow-false) (throw type-error))
|
||||
(return (lookup-qualified-variable e a (name :identifier))))))
|
||||
|
||||
(rule :qualified-identifier ((verify (-> (verify-env) void)) (eval (-> (dynamic-env) reference)))
|
||||
@ -1093,7 +1048,7 @@
|
||||
(const r reference ((eval :postfix-expression-or-super) e))
|
||||
(const a object (read-reference r))
|
||||
(const sa class-opt ((super :postfix-expression-or-super) e))
|
||||
(const b object (unary-dispatch increment-table sa null a (vector-of object) (vector-of named-argument)))
|
||||
(const b object (unary-dispatch increment-table sa null a (vector-of object) (list-set-of named-argument)))
|
||||
(write-reference r b)
|
||||
(return b)))
|
||||
(production :unary-expression (-- :postfix-expression-or-super) unary-expression-decrement
|
||||
@ -1102,7 +1057,7 @@
|
||||
(const r reference ((eval :postfix-expression-or-super) e))
|
||||
(const a object (read-reference r))
|
||||
(const sa class-opt ((super :postfix-expression-or-super) e))
|
||||
(const b object (unary-dispatch decrement-table sa null a (vector-of object) (vector-of named-argument)))
|
||||
(const b object (unary-dispatch decrement-table sa null a (vector-of object) (list-set-of named-argument)))
|
||||
(write-reference r b)
|
||||
(return b)))
|
||||
(production :unary-expression (+ :unary-expression-or-super) unary-expression-plus
|
||||
@ -1110,19 +1065,19 @@
|
||||
((eval e)
|
||||
(const a object (read-reference ((eval :unary-expression-or-super) e)))
|
||||
(const sa class-opt ((super :unary-expression-or-super) e))
|
||||
(return (unary-dispatch plus-table sa null a (vector-of object) (vector-of named-argument)))))
|
||||
(return (unary-dispatch plus-table sa null a (vector-of object) (list-set-of named-argument)))))
|
||||
(production :unary-expression (- :unary-expression-or-super) unary-expression-minus
|
||||
(verify (verify :unary-expression-or-super))
|
||||
((eval e)
|
||||
(const a object (read-reference ((eval :unary-expression-or-super) e)))
|
||||
(const sa class-opt ((super :unary-expression-or-super) e))
|
||||
(return (unary-dispatch minus-table sa null a (vector-of object) (vector-of named-argument)))))
|
||||
(return (unary-dispatch minus-table sa null a (vector-of object) (list-set-of named-argument)))))
|
||||
(production :unary-expression (~ :unary-expression-or-super) unary-expression-bitwise-not
|
||||
(verify (verify :unary-expression-or-super))
|
||||
((eval e)
|
||||
(const a object (read-reference ((eval :unary-expression-or-super) e)))
|
||||
(const sa class-opt ((super :unary-expression-or-super) e))
|
||||
(return (unary-dispatch bitwise-not-table sa null a (vector-of object) (vector-of named-argument)))))
|
||||
(return (unary-dispatch bitwise-not-table sa null a (vector-of object) (list-set-of named-argument)))))
|
||||
(production :unary-expression (! :unary-expression) unary-expression-logical-not
|
||||
(verify (verify :unary-expression))
|
||||
((eval e)
|
||||
@ -1785,10 +1740,8 @@
|
||||
((verify s) ((verify :substatement) (add-label s (name :identifier))))
|
||||
((eval e d)
|
||||
(catch ((return ((eval :substatement) e d)))
|
||||
(x) (if (:narrow-true (in (tag go-break) x))
|
||||
(if (= (& label x) (name :identifier) string)
|
||||
(return (& value x))
|
||||
(throw x))
|
||||
(x) (if (and (in x go-break :narrow-true) (= (& label x) (name :identifier) string))
|
||||
(return (& value x))
|
||||
(throw x))))))
|
||||
(%print-actions)
|
||||
|
||||
@ -1875,18 +1828,18 @@
|
||||
(rule :continue-statement ((verify (-> (verify-env) void)) (eval (-> (dynamic-env object) object)))
|
||||
(production :continue-statement (continue) continue-statement-unlabeled
|
||||
((verify (s :unused)) (todo))
|
||||
((eval (e :unused) d) (throw (tag go-continue d ""))))
|
||||
((eval (e :unused) d) (throw (new go-continue d ""))))
|
||||
(production :continue-statement (continue :no-line-break :identifier) continue-statement-labeled
|
||||
((verify (s :unused)) (todo))
|
||||
((eval (e :unused) d) (throw (tag go-continue d (name :identifier))))))
|
||||
((eval (e :unused) d) (throw (new go-continue d (name :identifier))))))
|
||||
|
||||
(rule :break-statement ((verify (-> (verify-env) void)) (eval (-> (dynamic-env object) object)))
|
||||
(production :break-statement (break) break-statement-unlabeled
|
||||
((verify (s :unused)) (todo))
|
||||
((eval (e :unused) d) (throw (tag go-break d ""))))
|
||||
((eval (e :unused) d) (throw (new go-break d ""))))
|
||||
(production :break-statement (break :no-line-break :identifier) break-statement-labeled
|
||||
((verify (s :unused)) (todo))
|
||||
((eval (e :unused) d) (throw (tag go-break d (name :identifier))))))
|
||||
((eval (e :unused) d) (throw (new go-break d (name :identifier))))))
|
||||
(%print-actions)
|
||||
|
||||
|
||||
@ -1896,13 +1849,13 @@
|
||||
((verify s)
|
||||
(when (not (& can-return s))
|
||||
(throw syntax-error)))
|
||||
((eval (e :unused)) (throw (tag go-return undefined))))
|
||||
((eval (e :unused)) (throw (new go-return undefined))))
|
||||
(production :return-statement (return :no-line-break (:list-expression allow-in)) return-statement-expression
|
||||
((verify s)
|
||||
(when (not (& can-return s))
|
||||
(throw syntax-error))
|
||||
((verify :list-expression) s))
|
||||
((eval e) (throw (tag go-return (read-reference ((eval :list-expression) e)))))))
|
||||
((eval e) (throw (new go-return (read-reference ((eval :list-expression) e)))))))
|
||||
(%print-actions)
|
||||
|
||||
|
||||
|
||||
@ -49,37 +49,34 @@
|
||||
(%charclass :unicode-alphanumeric)
|
||||
(%charclass :line-terminator)
|
||||
|
||||
(define line-terminators (set character) (set-of character #?000A #?000D #?2028 #?2029))
|
||||
(define re-whitespaces (set character) (set-of character #?000C #?000A #?000D #?0009 #?000B #\space))
|
||||
(define re-digits (set character) (set-of-ranges character #\0 #\9))
|
||||
(define re-word-characters (set character) (set-of-ranges character #\0 #\9 #\A #\Z #\a #\z #\_ nil))
|
||||
(define line-terminators (range-set character) (range-set-of character #?000A #?000D #?2028 #?2029))
|
||||
(define re-whitespaces (range-set character) (range-set-of character #?000C #?000A #?000D #?0009 #?000B #\space))
|
||||
(define re-digits (range-set character) (range-set-of-ranges character #\0 #\9))
|
||||
(define re-word-characters (range-set character) (range-set-of-ranges character #\0 #\9 #\A #\Z #\a #\z #\_ nil))
|
||||
(%print-actions)
|
||||
|
||||
|
||||
(%section "Regular Expression Definitions")
|
||||
(deftag re-input (str string) (ignore-case boolean) (multiline boolean) (span boolean))
|
||||
(deftype r-e-input (tag re-input))
|
||||
(deftuple r-e-input (str string) (ignore-case boolean) (multiline boolean) (span boolean))
|
||||
(%text :semantics
|
||||
"Field " (:label re-input str) " is the input string. "
|
||||
(:label re-input ignore-case) ", "
|
||||
(:label re-input multiline) ", and "
|
||||
(:label re-input span) " are the corresponding regular expression flags.")
|
||||
"Field " (:label r-e-input str) " is the input string. "
|
||||
(:label r-e-input ignore-case) ", "
|
||||
(:label r-e-input multiline) ", and "
|
||||
(:label r-e-input span) " are the corresponding regular expression flags.")
|
||||
|
||||
(deftag present (s string))
|
||||
(deftag absent)
|
||||
(deftype capture (tag present absent))
|
||||
(deftag undefined)
|
||||
(deftype capture (union string (tag undefined)))
|
||||
|
||||
(deftag re-match (end-index integer) (captures (vector capture)))
|
||||
(deftype r-e-match (tag re-match))
|
||||
(deftuple r-e-match (end-index integer) (captures (vector capture)))
|
||||
(deftag failure)
|
||||
(deftype r-e-result (tag re-match failure))
|
||||
(deftype r-e-result (union r-e-match (tag failure)))
|
||||
(%text :semantics
|
||||
"A " (:type r-e-match) " holds an intermediate state during the pattern-matching process. "
|
||||
(:label re-match end-index)
|
||||
(:label r-e-match end-index)
|
||||
" is the index of the next input character to be matched by the next component in a regular expression pattern. "
|
||||
"If we are at the end of the pattern, " (:label re-match end-index)
|
||||
"If we are at the end of the pattern, " (:label r-e-match end-index)
|
||||
" is one plus the index of the last matched input character. "
|
||||
(:label re-match captures)
|
||||
(:label r-e-match captures)
|
||||
" is a zero-based array of the strings captured so far by capturing parentheses.")
|
||||
|
||||
(deftype continuation (-> (r-e-match) r-e-result))
|
||||
@ -87,7 +84,7 @@
|
||||
"A " (:type continuation)
|
||||
" is a function that attempts to match the remaining portion of the pattern against the input string, "
|
||||
"starting at the intermediate state given by its " (:type r-e-match) " argument. "
|
||||
"If a match is possible, it returns a " (:tag re-match)
|
||||
"If a match is possible, it returns a " (:type r-e-match)
|
||||
" result that contains the final state; if no match is possible, it returns a " (:tag failure) " result.")
|
||||
|
||||
(deftype matcher (-> (r-e-input r-e-match continuation) r-e-result))
|
||||
@ -108,14 +105,14 @@
|
||||
"of the pattern. The " (:type integer) " parameter contains the number of capturing left parentheses seen so far in the "
|
||||
"pattern and is used to assign static, consecutive numbers to capturing parentheses.")
|
||||
|
||||
(define (character-set-matcher (acceptance-set (set character)) (invert boolean)) matcher ;*********ignore case?
|
||||
(define (character-set-matcher (acceptance-set (range-set character)) (invert boolean)) matcher ;*********ignore case?
|
||||
(function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(const i integer (& end-index x))
|
||||
(const s string (& str t))
|
||||
(cond
|
||||
((= i (length s)) (return failure))
|
||||
((xor (character-set-member (nth s i) acceptance-set) invert)
|
||||
(return (c (tag re-match (+ i 1) (& captures x)))))
|
||||
((xor (set-in (nth s i) acceptance-set) invert)
|
||||
(return (c (new r-e-match (+ i 1) (& captures x)))))
|
||||
(nil (return failure))))
|
||||
(return m))
|
||||
(%text :semantics
|
||||
@ -127,7 +124,7 @@
|
||||
(:local acceptance-set) " set of characters (possibly ignoring case).")
|
||||
|
||||
(define (character-matcher (ch character)) matcher
|
||||
(return (character-set-matcher (set-of character ch) false)))
|
||||
(return (character-set-matcher (range-set-of character ch) false)))
|
||||
(%text :semantics
|
||||
(:global character-matcher) " returns a " (:type matcher)
|
||||
" that matches a single input string character. The match succeeds if the character is the same as "
|
||||
@ -144,7 +141,7 @@
|
||||
(begin
|
||||
(const m1 matcher ((gen-matcher :disjunction) 0))
|
||||
(function (e (t r-e-input) (index integer)) r-e-result
|
||||
(const x r-e-match (tag re-match index (fill-capture (count-parens :disjunction))))
|
||||
(const x r-e-match (new r-e-match index (fill-capture (count-parens :disjunction))))
|
||||
(return (m1 t x success-continuation)))
|
||||
(return e)))))
|
||||
|
||||
@ -154,7 +151,7 @@
|
||||
(define (fill-capture (i integer)) (vector capture)
|
||||
(if (= i 0)
|
||||
(return (vector-of capture))
|
||||
(return (append (fill-capture (- i 1)) (vector-of capture absent)))))
|
||||
(return (append (fill-capture (- i 1)) (vector-of capture undefined)))))
|
||||
|
||||
|
||||
(%subsection "Disjunctions")
|
||||
@ -221,7 +218,7 @@
|
||||
(const min integer (minimum :quantifier))
|
||||
(const max limit (maximum :quantifier))
|
||||
(const greedy boolean (greedy :quantifier))
|
||||
(when (:narrow-true (not-in (tag +infinity) max))
|
||||
(when (not-in max (tag +infinity) :narrow-true)
|
||||
(rwhen (< max min)
|
||||
(throw syntax-error)))
|
||||
(return (repeat-matcher m min max greedy paren-index (count-parens :atom))))
|
||||
@ -274,9 +271,9 @@
|
||||
(var captures (vector capture) (& captures x))
|
||||
(var i integer p)
|
||||
(while (< i (+ p n-parens))
|
||||
(<- captures (set-nth captures i absent))
|
||||
(<- captures (set-nth captures i undefined))
|
||||
(<- i (+ i 1)))
|
||||
(return (tag re-match (& end-index x) captures)))
|
||||
(return (new r-e-match (& end-index x) captures)))
|
||||
|
||||
(define (repeat-matcher (body matcher) (min integer) (max limit) (greedy boolean) (paren-index integer) (n-body-parens integer)) matcher
|
||||
(function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
@ -289,7 +286,7 @@
|
||||
(when (/= min 0)
|
||||
(<- new-min (- min 1)))
|
||||
(var new-max limit max)
|
||||
(when (:narrow-true (not-in (tag +infinity) max))
|
||||
(when (not-in max (tag +infinity) :narrow-true)
|
||||
(<- new-max (- max 1)))
|
||||
(const m2 matcher (repeat-matcher body new-min new-max greedy paren-index n-body-parens))
|
||||
(return (m2 t y c)))
|
||||
@ -318,12 +315,12 @@
|
||||
((test-assertion t x)
|
||||
(return (or (= (& end-index x) 0)
|
||||
(and (& multiline t)
|
||||
(character-set-member (nth (& str t) (- (& end-index x) 1)) line-terminators))))))
|
||||
(set-in (nth (& str t) (- (& end-index x) 1)) line-terminators))))))
|
||||
(production :assertion (#\$) assertion-end
|
||||
((test-assertion t x)
|
||||
(return (or (= (& end-index x) (length (& str t)))
|
||||
(and (& multiline t)
|
||||
(character-set-member (nth (& str t) (& end-index x)) line-terminators))))))
|
||||
(set-in (nth (& str t) (& end-index x)) line-terminators))))))
|
||||
(production :assertion (#\\ #\b) assertion-word-boundary
|
||||
((test-assertion t x)
|
||||
(return (at-word-boundary (& end-index x) (& str t)))))
|
||||
@ -339,7 +336,7 @@
|
||||
(define (in-word (i integer) (s string)) boolean
|
||||
(if (or (= i -1) (= i (length s)))
|
||||
(return false)
|
||||
(return (character-set-member (nth s i) re-word-characters))))
|
||||
(return (set-in (nth s i) re-word-characters))))
|
||||
|
||||
|
||||
(%section "Atoms")
|
||||
@ -352,9 +349,7 @@
|
||||
(production :atom (#\.) atom-dot
|
||||
((gen-matcher (paren-index :unused))
|
||||
(function (m1 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(var a (set character) line-terminators)
|
||||
(when (& span t)
|
||||
(<- a (set-of character)))
|
||||
(const a (range-set character) (if (& span t) (range-set-of character) line-terminators))
|
||||
(const m2 matcher (character-set-matcher a true))
|
||||
(return (m2 t x c)))
|
||||
(return m1))
|
||||
@ -370,7 +365,7 @@
|
||||
(count-parens 0))
|
||||
(production :atom (:character-class) atom-character-class
|
||||
((gen-matcher (paren-index :unused))
|
||||
(const a (set character) (acceptance-set :character-class))
|
||||
(const a (range-set character) (acceptance-set :character-class))
|
||||
(return (character-set-matcher a (invert :character-class))))
|
||||
(count-parens 0))
|
||||
(production :atom (#\( :disjunction #\)) atom-parentheses
|
||||
@ -378,10 +373,10 @@
|
||||
(const m1 matcher ((gen-matcher :disjunction) (+ paren-index 1)))
|
||||
(function (m2 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(function (d (y r-e-match)) r-e-result
|
||||
(const ref capture (tag present (subseq (& str t) (& end-index x) (- (& end-index y) 1))))
|
||||
(const ref capture (subseq (& str t) (& end-index x) (- (& end-index y) 1)))
|
||||
(const updated-captures (vector capture)
|
||||
(set-nth (& captures y) paren-index ref))
|
||||
(return (c (tag re-match (& end-index y) updated-captures))))
|
||||
(return (c (new r-e-match (& end-index y) updated-captures))))
|
||||
(return (m1 t x d)))
|
||||
(return m2))
|
||||
(count-parens (+ (count-parens :disjunction) 1)))
|
||||
@ -393,11 +388,11 @@
|
||||
(const m1 matcher ((gen-matcher :disjunction) paren-index))
|
||||
(function (m2 (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
;(function (d (y r-e-match)) r-e-result
|
||||
; (return (c (tag re-match (& end-index x) (& captures y)))))
|
||||
; (return (c (new r-e-match (& end-index x) (& captures y)))))
|
||||
;(return (m1 t x d)))))
|
||||
(const y r-e-result (m1 t x success-continuation))
|
||||
(case y
|
||||
(:narrow r-e-match (return (c (tag re-match (& end-index x) (& captures y)))))
|
||||
(:narrow r-e-match (return (c (new r-e-match (& end-index x) (& captures y)))))
|
||||
(:select (tag failure) (return failure))))
|
||||
(return m2))
|
||||
(count-parens (count-parens :disjunction)))
|
||||
@ -439,15 +434,15 @@
|
||||
(function (m (t r-e-input) (x r-e-match) (c continuation)) r-e-result
|
||||
(const ref capture (nth-backreference x n))
|
||||
(case ref
|
||||
(:narrow (tag present)
|
||||
(:narrow string
|
||||
(const i integer (& end-index x))
|
||||
(const s string (& str t))
|
||||
(const j integer (+ i (length (& s ref))))
|
||||
(const j integer (+ i (length ref)))
|
||||
(if (and (<= j (length s))
|
||||
(= (subseq s i (- j 1)) (& s ref) string)) ;*********ignore case?
|
||||
(return (c (tag re-match j (& captures x))))
|
||||
(= (subseq s i (- j 1)) ref string)) ;*********ignore case?
|
||||
(return (c (new r-e-match j (& captures x))))
|
||||
(return failure)))
|
||||
(:select (tag absent) (return (c x)))))
|
||||
(:select (tag undefined) (return (c x)))))
|
||||
(return m))
|
||||
|
||||
(define (nth-backreference (x r-e-match) (n integer)) capture
|
||||
@ -515,25 +510,25 @@
|
||||
|
||||
(%subsection "Character Class Escapes")
|
||||
|
||||
(rule :character-class-escape ((acceptance-set (set character)))
|
||||
(rule :character-class-escape ((acceptance-set (range-set character)))
|
||||
(production :character-class-escape (#\s) character-class-escape-whitespace
|
||||
(acceptance-set re-whitespaces))
|
||||
(production :character-class-escape (#\S) character-class-escape-non-whitespace
|
||||
(acceptance-set (character-set-difference (set-of-ranges character #?0000 #?FFFF) re-whitespaces)))
|
||||
(acceptance-set (set- (range-set-of-ranges character #?0000 #?FFFF) re-whitespaces)))
|
||||
(production :character-class-escape (#\d) character-class-escape-digit
|
||||
(acceptance-set re-digits))
|
||||
(production :character-class-escape (#\D) character-class-escape-non-digit
|
||||
(acceptance-set (character-set-difference (set-of-ranges character #?0000 #?FFFF) re-digits)))
|
||||
(acceptance-set (set- (range-set-of-ranges character #?0000 #?FFFF) re-digits)))
|
||||
(production :character-class-escape (#\w) character-class-escape-word
|
||||
(acceptance-set re-word-characters))
|
||||
(production :character-class-escape (#\W) character-class-escape-non-word
|
||||
(acceptance-set (character-set-difference (set-of-ranges character #?0000 #?FFFF) re-word-characters))))
|
||||
(acceptance-set (set- (range-set-of-ranges character #?0000 #?FFFF) re-word-characters))))
|
||||
(%print-actions)
|
||||
|
||||
|
||||
(%section "User-Specified Character Classes")
|
||||
|
||||
(rule :character-class ((acceptance-set (set character)) (invert boolean))
|
||||
(rule :character-class ((acceptance-set (range-set character)) (invert boolean))
|
||||
(production :character-class (#\[ (:- #\^) :class-ranges #\]) character-class-positive
|
||||
(acceptance-set (acceptance-set :class-ranges))
|
||||
(invert false))
|
||||
@ -541,61 +536,61 @@
|
||||
(acceptance-set (acceptance-set :class-ranges))
|
||||
(invert true)))
|
||||
|
||||
(rule :class-ranges ((acceptance-set (set character)))
|
||||
(rule :class-ranges ((acceptance-set (range-set character)))
|
||||
(production :class-ranges () class-ranges-none
|
||||
(acceptance-set (set-of character)))
|
||||
(acceptance-set (range-set-of character)))
|
||||
(production :class-ranges ((:nonempty-class-ranges dash)) class-ranges-some
|
||||
(acceptance-set (acceptance-set :nonempty-class-ranges))))
|
||||
|
||||
(grammar-argument :delta dash no-dash)
|
||||
|
||||
(rule (:nonempty-class-ranges :delta) ((acceptance-set (set character)))
|
||||
(rule (:nonempty-class-ranges :delta) ((acceptance-set (range-set character)))
|
||||
(production (:nonempty-class-ranges :delta) ((:class-atom dash)) nonempty-class-ranges-final
|
||||
(acceptance-set (acceptance-set :class-atom)))
|
||||
(production (:nonempty-class-ranges :delta) ((:class-atom :delta) (:nonempty-class-ranges no-dash)) nonempty-class-ranges-non-final
|
||||
(acceptance-set
|
||||
(character-set-union (acceptance-set :class-atom)
|
||||
(acceptance-set :nonempty-class-ranges))))
|
||||
(set+ (acceptance-set :class-atom)
|
||||
(acceptance-set :nonempty-class-ranges))))
|
||||
(production (:nonempty-class-ranges :delta) ((:class-atom :delta) #\- (:class-atom dash) :class-ranges) nonempty-class-ranges-range
|
||||
(acceptance-set
|
||||
(character-set-union (character-range (acceptance-set :class-atom 1) (acceptance-set :class-atom 2))
|
||||
(acceptance-set :class-ranges))))
|
||||
(set+ (character-range (acceptance-set :class-atom 1) (acceptance-set :class-atom 2))
|
||||
(acceptance-set :class-ranges))))
|
||||
(production (:nonempty-class-ranges :delta) (:null-escape :class-ranges) nonempty-class-ranges-null-escape
|
||||
(acceptance-set (acceptance-set :class-ranges))))
|
||||
(%print-actions)
|
||||
|
||||
(define (character-range (low (set character)) (high (set character))) (set character)
|
||||
(rwhen (or (/= (character-set-length low) 1) (/= (character-set-length high) 1))
|
||||
(define (character-range (low (range-set character)) (high (range-set character))) (range-set character)
|
||||
(rwhen (or (/= (length low) 1) (/= (length high) 1))
|
||||
(throw syntax-error))
|
||||
(const l character (character-set-min low))
|
||||
(const h character (character-set-min high))
|
||||
(if (<= l h character)
|
||||
(return (set-of-ranges character l h))
|
||||
(return (range-set-of-ranges character l h))
|
||||
(throw syntax-error)))
|
||||
|
||||
|
||||
(%subsection "Character Class Range Atoms")
|
||||
|
||||
(rule (:class-atom :delta) ((acceptance-set (set character)))
|
||||
(rule (:class-atom :delta) ((acceptance-set (range-set character)))
|
||||
(production (:class-atom :delta) ((:class-character :delta)) class-atom-character
|
||||
(acceptance-set (set-of character ($default-action :class-character))))
|
||||
(acceptance-set (range-set-of character ($default-action :class-character))))
|
||||
(production (:class-atom :delta) (#\\ :class-escape) class-atom-escape
|
||||
(acceptance-set (acceptance-set :class-escape))))
|
||||
|
||||
(%charclass (:class-character dash))
|
||||
(%charclass (:class-character no-dash))
|
||||
|
||||
(rule :class-escape ((acceptance-set (set character)))
|
||||
(rule :class-escape ((acceptance-set (range-set character)))
|
||||
(production :class-escape (:decimal-escape) class-escape-decimal
|
||||
(acceptance-set
|
||||
(begin
|
||||
(if (= (escape-value :decimal-escape) 0)
|
||||
(return (set-of character #?0000))
|
||||
(return (range-set-of character #?0000))
|
||||
(throw syntax-error)))))
|
||||
(production :class-escape (#\b) class-escape-backspace
|
||||
(acceptance-set (set-of character #?0008)))
|
||||
(acceptance-set (range-set-of character #?0008)))
|
||||
(production :class-escape (:character-escape) class-escape-character-escape
|
||||
(acceptance-set (set-of character (character-value :character-escape))))
|
||||
(acceptance-set (range-set-of character (character-value :character-escape))))
|
||||
(production :class-escape (:character-class-escape) class-escape-character-class-escape
|
||||
(acceptance-set (acceptance-set :character-class-escape))))
|
||||
(%print-actions)
|
||||
@ -609,9 +604,9 @@
|
||||
(defun run-regexp (regexp input &key ignore-case multiline span)
|
||||
(let ((execute (first (lexer-parse *rl* regexp))))
|
||||
(dotimes (i (length input) :failure)
|
||||
(let ((result (funcall execute (list 'r:re-input input ignore-case multiline span) i)))
|
||||
(let ((result (funcall execute (list 'r:r-e-input input ignore-case multiline span) i)))
|
||||
(unless (eq result :failure)
|
||||
(assert-true (eq (first result) 'r:re-match))
|
||||
(assert-true (eq (first result) 'r:r-e-match))
|
||||
(return (list* i (subseq input i (second result)) (cddr result)))))))))
|
||||
|
||||
#|
|
||||
|
||||
@ -85,16 +85,15 @@
|
||||
(production (:unit-factor :sigma) (#\1 (:white-space wsopt) #\^ (:white-space wsopt) :signed-integer (:white-space :sigma)) unit-factor-one-exponent
|
||||
(value (vector-of unit-factor)))
|
||||
(production (:unit-factor :sigma) (:identifier (:white-space :sigma)) unit-factor-identifier
|
||||
(value (vector (tag unit-factor (name :identifier) 1))))
|
||||
(value (vector (new unit-factor (name :identifier) 1))))
|
||||
(production (:unit-factor :sigma) (:identifier (:white-space wsopt) #\^ (:white-space wsopt) :signed-integer (:white-space :sigma)) unit-factor-identifier-exponent
|
||||
(value (vector (tag unit-factor (name :identifier) (integer-value :signed-integer))))))
|
||||
(value (vector (new unit-factor (name :identifier) (integer-value :signed-integer))))))
|
||||
|
||||
(deftag unit-factor (identifier string) (exponent integer))
|
||||
(deftype unit-factor (tag unit-factor))
|
||||
(deftuple unit-factor (identifier string) (exponent integer))
|
||||
(deftype unit-list (vector unit-factor))
|
||||
|
||||
(define (unit-reciprocal (value unit-list)) unit-list
|
||||
(return (map value f (tag unit-factor (& identifier f) (neg (& exponent f))))))
|
||||
(return (map value f (new unit-factor (& identifier f) (neg (& exponent f))))))
|
||||
|
||||
(%print-actions)
|
||||
|
||||
|
||||
@ -8,16 +8,16 @@
|
||||
|
||||
(define (x-digit-value (c character)) integer
|
||||
(cond
|
||||
((character-set-member c (set-of-ranges character #\0 #\9))
|
||||
((set-in c (range-set-of-ranges character #\0 #\9))
|
||||
(return (- (character-to-code c) (character-to-code #\0))))
|
||||
((character-set-member c (set-of-ranges character #\A #\Z))
|
||||
((set-in c (range-set-of-ranges character #\A #\Z))
|
||||
(return (+ (- (character-to-code c) (character-to-code #\A)) 10)))
|
||||
((character-set-member c (set-of-ranges character #\a #\z))
|
||||
((set-in c (range-set-of-ranges character #\a #\z))
|
||||
(return (+ (- (character-to-code c) (character-to-code #\a)) 10)))
|
||||
(nil (bottom))))
|
||||
|
||||
(define (x-real-to-float64 (x rational)) float64
|
||||
(const s (set integer) (set-of integer (neg (expt 2 1024)) 0 (expt 2 1024)))
|
||||
(const s (range-set integer) (range-set-of integer (neg (expt 2 1024)) 0 (expt 2 1024)))
|
||||
(const a integer (integer-set-min s))
|
||||
(cond
|
||||
((= a (expt 2 1024)) (return +infinity))
|
||||
@ -27,7 +27,7 @@
|
||||
(nil (return +zero))))
|
||||
|
||||
(define (x-truncate-finite-float64 (x finite-float64)) integer
|
||||
(rwhen (:narrow-false (in (tag +zero -zero) x))
|
||||
(rwhen (in x (tag +zero -zero) :narrow-false)
|
||||
(return 0))
|
||||
(if (> x 0 rational)
|
||||
(return (floor x))
|
||||
|
||||
@ -211,6 +211,10 @@
|
||||
(defmacro assert-three-values (expr)
|
||||
`(assert-n-values 3 ,expr))
|
||||
|
||||
; Assert that expr returns four values. Return those values.
|
||||
(defmacro assert-four-values (expr)
|
||||
`(assert-n-values 4 ,expr))
|
||||
|
||||
|
||||
;;; ------------------------------------------------------------------------------------------------------
|
||||
;;; STRUCTURED TYPES
|
||||
@ -563,12 +567,12 @@
|
||||
|
||||
|
||||
; Return true if value is a member of the intset.
|
||||
(defun intset-member? (intset value)
|
||||
(defun intset-member? (value intset)
|
||||
(if (endp intset)
|
||||
nil
|
||||
(let ((first-range (first intset)))
|
||||
(if (> value (cdr first-range))
|
||||
(intset-member? (rest intset) value)
|
||||
(intset-member? value (rest intset))
|
||||
(>= value (car first-range))))))
|
||||
|
||||
|
||||
@ -648,6 +652,14 @@
|
||||
(defun intset= (intset1 intset2)
|
||||
(equal intset1 intset2))
|
||||
|
||||
(defconstant intset=-name 'equal)
|
||||
|
||||
|
||||
; Return true if the intset is empty.
|
||||
(declaim (inline intset-empty))
|
||||
(defun intset-empty (intset)
|
||||
(endp intset))
|
||||
|
||||
|
||||
; Return the number of elements in the intset.
|
||||
(defun intset-length (intset)
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user