From bce5683f9b47e230c6dc5b9f1ae6ebcfad3a4188 Mon Sep 17 00:00:00 2001 From: "waldemar%netscape.com" Date: Tue, 18 Feb 2003 00:28:37 +0000 Subject: [PATCH] Added support for definfix and non-reserved operators. Fixed operator precedence bugs. --- js2/semantics/Calculus.lisp | 55 ++++++++++--- js2/semantics/CalculusMarkup.lisp | 132 +++++++++++++++++++++--------- 2 files changed, 137 insertions(+), 50 deletions(-) diff --git a/js2/semantics/Calculus.lisp b/js2/semantics/Calculus.lisp index 14fadcf863b..3d31f6ddc2e 100644 --- a/js2/semantics/Calculus.lisp +++ b/js2/semantics/Calculus.lisp @@ -1202,6 +1202,8 @@ ;;; identifier is a type constructor like '->, 'vector, 'range-set, 'tag, or 'union ;;; :deftype type if this identifier is a type; nil if this identifier is a forward-referenced type ;;; +;;; :non-reserved true if this symbol is usable as an identifier despite being a :special-form, :condition, :primitive, or :type-constructor +;;; ;;; value of this identifier if it is a variable of type other than -> ;;; value of this identifier if it is a variable of type -> ;;; :value-expr unparsed expression defining the value of this identifier if it is a variable @@ -1321,7 +1323,12 @@ (fields nil :type list :read-only t) ;List of fields after eval-tags-types or (field-name field-type-expression [:const|:var|:opt-const|:opt-var]) before eval-tags-types (=-name nil :type symbol) ;Lazily computed name of a function that compares two values of this tag for equality; nil if not known yet (link nil :type (or null keyword) :read-only t) ;:reference if this is a local tag, :external if it's a predefined tag, or nil for no cross-references to this tag - (base nil :type integer :read-only t)) ;Position of first field in the list; -1 if it's special + (base nil :type integer :read-only t) ;Position of first field in the list; -1 if it's special + (appearance nil)) ;One of the following: +; ; nil to display the constructor normally +; ; (:suffix . markup) to display the constructor as a suffix (the constructor must be unary) +; ; (:infix . markup) to display the constructor as an infix (the constructor must be binary) + ; Return four values: ; the one-based position of the tag's field corresponding to the given label or nil if the label is not present; @@ -2660,7 +2667,8 @@ (unless (identifier? name) (error "~S should be an identifier" name)) (let ((symbol (world-intern world name))) - (when (get-properties (symbol-plist symbol) '(:special-form :condition :primitive :type-constructor)) + (when (and (get-properties (symbol-plist symbol) '(:special-form :condition :primitive :type-constructor)) + (not (get symbol :non-reserved))) (error "~A is reserved" symbol)) symbol)) @@ -5458,6 +5466,21 @@ (export-symbol symbol))) +; (definfix ) +; must be a tuple or record tag. Define the syntax for depicting its constructor to be the infix operator +; depicted by . and are used as parameter names for depicting the definfix definition itself. +(defun scan-definfix (world grammar-info-var type-name markup param1 param2) + (declare (ignore grammar-info-var param1 param2)) + (let* ((symbol (scan-name world type-name)) + (type (get-type symbol nil))) + (unless (eq (type-kind type) :tag) + (error "~A should be a tag type" (print-type-to-string type))) + (let ((tag (type-tag type))) + (when (tag-appearance tag) + (error "Duplicate appearance on tag ~S" tag)) + (setf (tag-appearance tag) (cons :infix markup))))) + + ; (set-grammar ) ; Set the current grammar to the grammar or lexer with the given name. (defun scan-set-grammar (world grammar-info-var name) @@ -5561,6 +5584,7 @@ (defun scan-define depict-defun) ;Occurs from desugaring a function define (defprimitive scan-defprimitive depict-defprimitive) (defvar scan-defvar depict-defvar) + (definfix scan-definfix depict-definfix) (set-grammar scan-set-grammar depict-set-grammar) (clear-grammar scan-clear-grammar depict-clear-grammar) (declare-action scan-declare-action depict-declare-action) @@ -5683,19 +5707,22 @@ (writable-cell scan-writable-cell depict-writable-cell)))) +(defparameter *default-non-reserved* '(length)) + + (defparameter *default-primitives* '((neg (-> (integer) integer) #'- :unary :minus nil %prefix% %prefix%) (abs (-> (integer) integer) #'abs :unary "|" "|" %primary% %expr%) (* (-> (integer integer) integer) #'* :infix :cartesian-product-10 nil %factor% %factor% %factor%) - (mod (-> (integer integer) integer) #'mod :infix ((:semantic-keyword "mod")) t %factor% %factor% %unary%) + (mod (-> (integer integer) integer) #'mod :infix ((:semantic-keyword "mod")) t %factor% %factor% %prefix%) (+ (-> (integer integer) integer) #'+ :infix "+" t %term% %term% %term%) (- (-> (integer integer) integer) #'- :infix :minus t %term% %term% %factor%) ;(rational-compare (-> (rational rational) order) #'rational-compare) - (rat-neg (-> (rational) rational) #'- :unary "-" nil %suffix% %suffix%) + (rat-neg (-> (rational) rational) #'- :unary :minus nil %prefix% %prefix%) (rat-abs (-> (rational) rational) #'abs :unary "|" "|" %primary% %expr%) (rat* (-> (rational rational) rational) #'* :infix :cartesian-product-10 nil %factor% %factor% %factor%) - (rat/ (-> (rational rational) rational) #'/ :infix "/" nil %factor% %factor% %unary%) + (rat/ (-> (rational rational) rational) #'/ :infix "/" nil %factor% %factor% %prefix%) (rat+ (-> (rational rational) rational) #'+ :infix "+" t %term% %term% %term%) (rat- (-> (rational rational) rational) #'- :infix :minus t %term% %term% %factor%) (floor (-> (rational) integer) #'floor :unary :left-floor-10 :right-floor-10 %primary% %expr%) @@ -5746,13 +5773,12 @@ ;;; Partial order of primitives for deciding when to depict parentheses. (defparameter *primitive-level* (make-partial-order)) -(def-partial-order-element *primitive-level* %primary%) ;id, constant, (e), tag<...>, |e|, action -(def-partial-order-element *primitive-level* %suffix% %primary%) ;f(...), a[i], a[i...j], a[i<-v], a.l -(def-partial-order-element *primitive-level* %prefix% %primary%) ;-e, new tag<...>, a^b +(def-partial-order-element *primitive-level* %primary%) ;id, constant, (e), tag<...>, |e| +(def-partial-order-element *primitive-level* %suffix% %primary%) ;f(...), a[i], a[i...j], a[i<-v], a.l, action +(def-partial-order-element *primitive-level* %prefix% %suffix%) ;-e, new tag<...>, a^b (def-partial-order-element *primitive-level* %min-max% %prefix%) ;min, max -(def-partial-order-element *primitive-level* %unary% %suffix% %prefix%) ; -(def-partial-order-element *primitive-level* %not% %unary%) ;not -(def-partial-order-element *primitive-level* %factor% %unary%) ;/, *, intersection +(def-partial-order-element *primitive-level* %not% %prefix%) ;not +(def-partial-order-element *primitive-level* %factor% %prefix%) ;/, *, intersection, tuple-infix (def-partial-order-element *primitive-level* %term% %factor%) ;+, -, append, union, set difference (def-partial-order-element *primitive-level* %relational% %term% %min-max% %not%) ;<, <=, >, >=, =, /=, is, member, ... (def-partial-order-element *primitive-level* %logical% %relational%) ;and, or, xor @@ -5803,6 +5829,11 @@ property (world-intern world (first special-spec)) (rest special-spec))))) + (dolist (non-reserved *default-non-reserved*) + (let ((symbol (world-intern world non-reserved))) + (assert (get-properties (symbol-plist symbol) '(:special-form :condition :primitive :type-constructor))) + (setf (get symbol :non-reserved) t) + (export-symbol symbol))) (dolist (primitive-spec *default-primitives*) (let ((name (world-intern world (first primitive-spec)))) (apply #'declare-primitive @@ -5869,6 +5900,8 @@ (add-type-name world finite-float64-type (world-intern world 'finite-float64) nil) (let ((long-type (scan-deftuple-or-defrecord world nil 'long '((value (integer-range (neg (expt 2 63)) (- (expt 2 63) 1)))) nil)) (u-long-type (scan-deftuple-or-defrecord world nil 'u-long '((value (integer-range 0 (- (expt 2 64) 1)))) nil))) + (setf (tag-appearance (type-tag long-type)) '(:suffix (:subscript (:tag-name "long")))) + (setf (tag-appearance (type-tag u-long-type)) '(:suffix (:subscript (:tag-name "ulong")))) (add-type-name world (make-union-type world float32-type float64-type long-type u-long-type) (world-intern world 'general-number) nil) (add-type-name world (make-union-type world finite-float32-type finite-float64-type long-type u-long-type) (world-intern world 'finite-general-number) nil)))) diff --git a/js2/semantics/CalculusMarkup.lisp b/js2/semantics/CalculusMarkup.lisp index 4457303cdc0..103427137e6 100644 --- a/js2/semantics/CalculusMarkup.lisp +++ b/js2/semantics/CalculusMarkup.lisp @@ -187,13 +187,13 @@ (:-zero32 "MinusZero32" (:minus "zero" (:subscript "f32"))) (:+infinity32 "PlusInfinity32" ("+" :infinity (:subscript "f32"))) (:-infinity32 "MinusInfinity32" (:minus :infinity (:subscript "f32"))) - (:nan32 "NaN" ("NaN32" (:subscript "f32"))) + (:nan32 "NaN" ("NaN" (:subscript "f32"))) (:+zero64 "PlusZero64" ("+zero" (:subscript "f64"))) (:-zero64 "MinusZero64" (:minus "zero" (:subscript "f64"))) (:+infinity64 "PlusInfinity64" ("+" :infinity (:subscript "f64"))) (:-infinity64 "MinusInfinity64" (:minus :infinity (:subscript "f64"))) - (:nan64 "NaN" ("NaN64" (:subscript "f64"))) + (:nan64 "NaN" ("NaN" (:subscript "f64"))) (:+infinity "PlusInfinity" ("+" :infinity)) (:-infinity "MinusInfinity" (:minus :infinity)))) @@ -531,14 +531,15 @@ ; Emit markup for the reference to the action on the given general grammar symbol. -(defun depict-action-reference (markup-stream action-name general-grammar-symbol &optional index) - (let ((action-default (default-action? action-name))) - (unless action-default - (depict-action-name markup-stream action-name) - (depict markup-stream :action-begin)) - (depict-general-grammar-symbol markup-stream general-grammar-symbol :reference index) - (unless action-default - (depict markup-stream :action-end)))) +(defun depict-action-reference (markup-stream level action-name general-grammar-symbol &optional index) + (cond + ((default-action? action-name) + (depict-general-grammar-symbol markup-stream general-grammar-symbol :reference index)) + (t (depict-expr-parentheses (markup-stream level %suffix%) + (depict-action-name markup-stream action-name) + (depict markup-stream :action-begin) + (depict-general-grammar-symbol markup-stream general-grammar-symbol :reference index) + (depict markup-stream :action-end))))) ; Emit markup for the given annotated value expression. level indicates the binding level imposed @@ -553,7 +554,7 @@ (expr-annotation:local (depict-local-variable markup-stream (first args))) (expr-annotation:global (depict-global-variable markup-stream (first args) :reference)) (expr-annotation:call (apply #'depict-call markup-stream world level args)) - (expr-annotation:action (apply #'depict-action-reference markup-stream args)) + (expr-annotation:action (apply #'depict-action-reference markup-stream level args)) (expr-annotation:special-form (apply (get (first args) :depict-special-form) markup-stream world level (rest args)))))) @@ -947,39 +948,55 @@ ; A may be :uninit to indicate an uninitialized field, which must have kind :opt-const or :opt-var. (defun depict-new (markup-stream world level type type-name &rest annotated-exprs) (let* ((tag (type-tag type)) - (mutable (tag-mutable tag))) + (appearance (tag-appearance tag)) + (mutable (tag-mutable tag)) + (fields (tag-fields tag)) + (n-fields (length fields))) (flet ((depict-tag-and-args (markup-stream) - (let ((fields (tag-fields tag))) - (assert-true (= (length fields) (length annotated-exprs))) - (depict-type-name markup-stream type-name (if (symbol-type-user-defined (world-intern world type-name)) :reference :external)) - (if (tag-keyword tag) - (assert-true (null annotated-exprs)) - (let ((fields-and-parameters (mapcan #'(lambda (field parameter) - (and (not (eq parameter :uninit)) - (list (cons field parameter)))) - fields annotated-exprs))) - (depict-list markup-stream - #'(lambda (markup-stream field-and-parameter) - (depict-logical-block (markup-stream 4) - (depict-label-name markup-stream world type (field-label (car field-and-parameter)) nil) - (depict markup-stream ":") - (depict-break markup-stream 1) - (depict-expression markup-stream world (cdr field-and-parameter) %expr%))) - fields-and-parameters - :indent 4 - :prefix (if mutable :record-begin :tuple-begin) - :suffix (if mutable :record-end :tuple-end) - :separator "," - :break 1 - :empty nil)))))) + (depict-type-name markup-stream type-name (if (symbol-type-user-defined (world-intern world type-name)) :reference :external)) + (if (tag-keyword tag) + (assert-true (null annotated-exprs)) + (let ((fields-and-parameters (mapcan #'(lambda (field parameter) + (and (not (eq parameter :uninit)) + (list (cons field parameter)))) + fields annotated-exprs))) + (depict-list markup-stream + #'(lambda (markup-stream field-and-parameter) + (depict-logical-block (markup-stream 4) + (depict-label-name markup-stream world type (field-label (car field-and-parameter)) nil) + (depict markup-stream ":") + (depict-break markup-stream 1) + (depict-expression markup-stream world (cdr field-and-parameter) %expr%))) + fields-and-parameters + :indent 4 + :prefix (if mutable :record-begin :tuple-begin) + :suffix (if mutable :record-end :tuple-end) + :separator "," + :break 1 + :empty nil))))) - (if mutable + (assert-true (= n-fields (length annotated-exprs))) + (cond + (appearance + (ecase (first appearance) + (:suffix + (assert-true (= n-fields 1)) + (depict-expr-parentheses (markup-stream level %suffix%) + (depict-expression markup-stream world (first annotated-exprs) %primary%) + (depict-item-or-group-list markup-stream (rest appearance)))) + (:infix + (assert-true (= n-fields 2)) + (depict-expr-parentheses (markup-stream level %factor%) + (depict-expression markup-stream world (first annotated-exprs) %primary%) + (depict-item-or-group-list markup-stream (rest appearance)) + (depict-expression markup-stream world (second annotated-exprs) %primary%))))) + (mutable (depict-expr-parentheses (markup-stream level %prefix%) (depict-logical-block (markup-stream 4) (depict-semantic-keyword markup-stream 'new :after) - (depict-tag-and-args markup-stream))) - (depict-tag-and-args markup-stream))))) + (depict-tag-and-args markup-stream)))) + (t (depict-tag-and-args markup-stream)))))) ; (&