Added support for writable actions

js2/semantics/Calculus.lisp

@@ -830,6 +830,7 @@
 ;;;   <value>        value of this identifier if it is a variable of type other than ->
 ;;;   <function>     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
+;;;   :mutable       if present and non-nil, this identifier is a mutable variable
 ;;;   :type          type of this identifier if it is a variable
 ;;;   :type-expr     unparsed expression defining the type of this identifier if it is a variable
 ;;;   :tag           tag structure if this identifier is a tag
@@ -1064,7 +1065,8 @@
            :range-set        ;nil              ;(element-type)
            :tag              ;tag              ;nil
            :denormalized-tag ;tag              ;nil
-           :union))   ;nil              ;(type ... type) sorted by ascending serial numbers
+           :union            ;nil              ;(type ... type) sorted by ascending serial numbers
+           :writable-cell))  ;nil              ;(element-type)
 
 ;A denormalized-tag is a singleton tag type whose value carries no meaning.
 ;
@@ -1158,6 +1160,16 @@
   (make-type world :denormalized-tag tag nil 'always-true 'always-false))
 
 
+(declaim (inline make-writable-cell-type))
+(defun make-writable-cell-type (world element-type)
+  (make-type world :writable-cell nil (list element-type) nil nil))
+
+(declaim (inline writable-cell-element-type))
+(defun writable-cell-element-type (type)
+  (assert-true (eq (type-kind type) :writable-cell))
+  (car (type-parameters type)))
+
+
 ; Return true if the type is a tag type or a union of tag types all of which have a field with
 ; the given label.
 (defun type-has-field (type label)
@@ -1593,6 +1605,9 @@
                   (print-type (pprint-pop) stream)
                   (pprint-exit-if-list-exhausted)
                   (format stream " ~:_"))))
+      (:writable-cell (pprint-logical-block (stream nil :prefix "(" :suffix ")")
+                        (format stream "writable-cell ~@_")
+                        (print-type (writable-cell-element-type type) stream)))
       (t (error "Bad typekind ~S" (type-kind type))))))
 
 
@@ -1719,6 +1734,11 @@
                                          type-exprs)))
 
 
+; (writable-cell <element-type>)
+(defun scan-writable-cell (world allow-forward-references element-type)
+  (make-writable-cell-type world (scan-type world element-type allow-forward-references)))
+
+
 ; Resolve all forward type references to refer to their target types.
 ; Signal an error if any unresolved type references remain.
 ; Only types reachable from some type name are affected.  It is the caller's
@@ -2115,6 +2135,7 @@
   ;                       ;   index is the one-based index used to distinguish among identical
   ;                       ;     symbols in the rhs of a production.  The first occurrence of this
   ;                       ;     symbol has index 1, the second has index 2, and so on.
+  ;                       ;     The occurrence of symbol on the left side of the production has index 0.
   local-symbol            ;A unique local variable name used to represent the action function's value in the generated lisp code
   type                    ;Type of the action function's value
   general-grammar-symbol) ;The general-grammar-symbol corresponding to the index-th instance of symbol in the production's rhs
@@ -2133,12 +2154,7 @@
 
 ; If the currently generated function is an action for a rule with at least index
 ; instances of the given grammar-symbol's symbol on the right-hand side, and if action is
-; a legal action for that symbol, return three values:
+; a legal action for that symbol, return the type-env-action; otherwise, return nil.
-;   the name to use from the generated lisp code to refer to the result of calling
-;     the action on the index-th instance of this symbol;
-;   the action result's type;
-;   the general-grammar-symbol corresponding to the index-th instance of this symbol in the rhs.
-; Otherwise, return nil.
 ; action must already be world-interned.
 (defun type-env-get-action (type-env action symbol index)
   (assoc (list* action symbol index) type-env :test #'equal))
@@ -2233,6 +2249,8 @@
 ;;;   A range-set of integers or characters (represented by an intset of its elements converted to integers)
 ;;;   A tag (represented by either a keyword or a list (keyword [serial-num] field-value1 ... field-value n));
 ;;;     serial-num is a unique integer present only on mutable tag instances.
+;;;   A writable-cell (represented by a cons whose car is a flag that is true if the cell is initialized
+;;;     and cdr is nil or the value)
 
 
 ; Return true if the value appears to have the given tag.  This function
@@ -2280,6 +2298,10 @@
     (:tag (value-has-tag value (type-tag type) shallow))
     (:union (some #'(lambda (subtype) (value-has-type value subtype shallow))
                   (type-parameters type)))
+    (:writable-cell (and (consp value)
+                         (if (car value)
+                           (or shallow (value-has-type (cdr value) (writable-cell-element-type type)))
+                           (null (cdr value)))))
     (t (error "Bad typekind ~S" (type-kind type)))))
 
 
@@ -2350,6 +2372,9 @@
               (when (value-has-type value subtype t)
                 (print-value value subtype stream)
                 (return))))
+    (:writable-cell (if (car value)
+                      (print-value (cdr value) (writable-cell-element-type type) stream)
+                      (write-string "uninitialized" stream)))
     (t (error "Bad typekind ~S" (type-kind type)))))
 
 
@@ -2404,7 +2429,7 @@
        (eq (second annotated-expr) (world-find-symbol world special-form))))
 
 
-; Return the value of the variable with the given symbol.
+; Return the value of the global variable with the given symbol.
 ; Compute the value if the variable was unbound.
 ; Use the *busy-variables* list to prevent infinite recursion while computing variable values.
 (defmacro fetch-value (symbol)
@@ -2413,6 +2438,38 @@
      (compute-variable-value ',symbol)))
 
 
+; Store the value into the global variable with the given symbol.
+(defmacro store-global-value (symbol value)
+  `(if (boundp ',symbol)
+     (setf (symbol-value ',symbol) ,value)
+     (error "Unbound variable ~S" ',symbol)))
+
+
+; Generate a lisp expression that will call the given action on the grammar symbol.
+; type-env is the type environment.
+; Return three values:
+;   The expression's value (a lisp expression)
+;   The expression's type
+;   The annotated value-expr
+(defun scan-action-call (type-env action symbol &optional (index 1 index-supplied))
+  (unless (integerp index)
+    (error "Production rhs grammar symbol index ~S must be an integer" index))
+  (let ((symbol-action (type-env-get-action type-env action symbol index)))
+    (unless symbol-action
+      (error "Action ~S not found" (list action symbol index)))
+    (let ((multiple-symbols (type-env-get-action type-env action symbol (if (= index 0) 1 2))))
+      (when (and (not index-supplied) multiple-symbols)
+        (error "Ambiguous index in action ~S" (list action symbol)))
+      (when (and (= index 1)
+                 (not multiple-symbols)
+                 (grammar-symbol-= symbol (assert-non-null (get-type-env-flag type-env :lhs-symbol))))
+        (setq multiple-symbols t))
+      (values (type-env-action-local-symbol symbol-action)
+              (type-env-action-type symbol-action)
+              (list* 'expr-annotation:action action (type-env-action-general-grammar-symbol symbol-action)
+                     (and multiple-symbols (list index)))))))
+
+
 ; Generate a lisp expression that will compute the value of value-expr.
 ; type-env is the type environment.  The expression may refer to free variables
 ; present in the type-env.
@@ -2459,23 +2516,6 @@
                          (->-result-type function-type)
                          (list* 'expr-annotation:call function-annotated-expr arg-annotated-exprs))))))))
      
-     ;Scan an action call
-     (scan-action-call (action symbol &optional (index 1 index-supplied))
-       (unless (integerp index)
-         (error "Production rhs grammar symbol index ~S must be an integer" index))
-       (let ((symbol-action (type-env-get-action type-env action symbol index)))
-         (unless symbol-action
-           (error "Action ~S not found" (list action symbol index)))
-         (let ((multiple-symbols (type-env-get-action type-env action symbol 2)))
-           (when (and (not index-supplied) multiple-symbols)
-             (error "Ambiguous index in action ~S" (list action symbol)))
-           (values (type-env-action-local-symbol symbol-action)
-                   (type-env-action-type symbol-action)
-                   (list* 'expr-annotation:action action (type-env-action-general-grammar-symbol symbol-action)
-                          (and (or multiple-symbols
-                                   (grammar-symbol-= symbol (assert-non-null (get-type-env-flag type-env :lhs-symbol))))
-                               (list index)))))))
-     
      ;Scan an interned identifier
      (scan-identifier (symbol)
        (let ((symbol-binding (type-env-get-local type-env symbol)))
@@ -2517,7 +2557,17 @@
                (if (and (symbol-action symbol)
                         (let ((local (type-env-get-local type-env symbol)))
                           (not (and local (eq (type-kind (type-env-local-type local)) :->)))))
-                 (apply #'scan-action-call symbol rest)
+                 (multiple-value-bind (action-value action-type action-annotated-expr) (apply #'scan-action-call type-env symbol rest)
+                   (if (eq (type-kind action-type) :writable-cell)
+                     (progn
+                       (assert-true (symbolp action-value))
+                       (values
+                        `(if (car ,action-value)
+                           (cdr ,action-value)
+                           (error "Uninitialized writable-cell"))
+                        (writable-cell-element-type action-type)
+                        action-annotated-expr))
+                     (values action-value action-type action-annotated-expr)))
                  (multiple-value-call #'scan-call (scan-identifier symbol) rest)))))
          (multiple-value-call #'scan-call (scan-value world type-env first) rest)))
      
@@ -3607,6 +3657,19 @@
        true-type-env))))
 
 
+;;; Writable Cells
+
+; (writable-cell-of <element-type>)
+; Makes an uninitialized writable cell of the given type.
+(defun scan-writable-cell-of (world type-env special-form element-type-expr)
+  (declare (ignore type-env))
+  (let ((element-type (scan-type world element-type-expr)))
+    (values
+     '(cons nil nil)
+     (make-writable-cell-type world element-type)
+     (list* 'expr-annotation:special-form special-form))))
+
+
 
 ;;; ------------------------------------------------------------------------------------------------------
 ;;; STATEMENT EXPRESSIONS
@@ -3653,15 +3716,16 @@
 ; Compute the initial type-env to use for the given general-production's action code.
 ; The first cell of the type-env gives the production's lhs nonterminal's symbol;
 ; the remaining cells give the action arguments in order.
-(defun general-production-action-env (grammar general-production)
+; If include-lhs is true, include the lhs's actions with index 0 at the beginning of the
-  (let* ((current-indices nil)
+; environment.
+(defun general-production-action-env (grammar general-production include-lhs)
+  (let* ((index-override nil)
+         (current-indices nil)
          (lhs-general-nonterminal (general-production-lhs general-production))
          (bound-arguments-alist (nonterminal-sample-bound-argument-alist grammar lhs-general-nonterminal)))
-    (set-type-env-flag 
+    (flet ((general-symbol-action-env (general-grammar-symbol)
-     (mapcan
-      #'(lambda (general-grammar-symbol)
              (let* ((symbol (general-grammar-symbol-symbol general-grammar-symbol))
-                 (index (incf (getf current-indices symbol 0)))
+                    (index (or index-override (incf (getf current-indices symbol 0))))
                     (grammar-symbol (instantiate-general-grammar-symbol bound-arguments-alist general-grammar-symbol)))
                (mapcar
                 #'(lambda (declaration)
@@ -3673,9 +3737,14 @@
                        local-symbol
                        action-type
                        general-grammar-symbol)))
-             (grammar-symbol-signature grammar grammar-symbol))))
+                (grammar-symbol-signature grammar grammar-symbol)))))
-      (general-production-rhs general-production))
+      (let ((env (set-type-env-flag 
+                  (mapcan #'general-symbol-action-env (general-production-rhs general-production))
                   :lhs-symbol (general-grammar-symbol-symbol lhs-general-nonterminal))))
+        (when include-lhs
+          (setq index-override 0)
+          (setq env (nconc (general-symbol-action-env lhs-general-nonterminal) env)))
+        env))))
 
 
 ; Return the number of arguments that a function returned by compute-action-code
@@ -3690,13 +3759,7 @@
 ; Compute the code for evaluating body-expr to obtain the value of one of the
 ; production's actions.  Verify that the result has the given type and that the
 ; type is the same as type-expr.
-; The code is a lambda-expression that takes as arguments the results of all
+(defun compute-action-code (world production action-symbol type-expr body-expr type initial-env)
-; defined actions on the production's rhs.  The arguments are listed in the
-; same order as the grammar symbols in the rhs.  If a grammar symbol in the rhs
-; has more than one associated action, arguments are used corresponding to all
-; of the actions in the same order as they were declared.  If a grammar symbol
-; in the rhs has no associated actions, no argument is used for it.
-(defun compute-action-code (world grammar production action-symbol type-expr body-expr type)
   (handler-bind (((or error warning)
                   #'(lambda (condition)
                       (declare (ignore condition))
@@ -3706,17 +3769,67 @@
       (unless (type= type type2)
         (error "Action declared using type ~A but defined using ~A"
                (print-type-to-string type) (print-type-to-string type2))))
-    (let* ((initial-env (general-production-action-env grammar production))
+    (let ((body-code (scan-typed-value-or-begin world initial-env body-expr type)))
-           (args (mapcar #'cadr (cdr initial-env)))
+      (name-lambda body-code
-           (body-code (scan-typed-value-or-begin world initial-env body-expr type))
-           (named-body-code (name-lambda body-code
                    (concatenate 'string (symbol-name (production-name production))
                                 "~" (symbol-name action-symbol))
-                                         (world-package world))))
+                   (world-package world)))))
-      (gen-lambda args named-body-code))))
 
 
-; Return a list of all grammar symbols's symbols that are present in at least one expr-annotation:action
+; Compute the body of all grammar actions for this production.
+(defun compute-production-code (world grammar production)
+  (let* ((lhs (production-lhs production))
+         (n-action-args (n-action-args grammar production))
+         (initial-env (general-production-action-env grammar production nil))
+         (args (mapcar #'cadr (cdr initial-env))))
+    (assert-true (= (length args) n-action-args))
+    (let* ((result-vars nil)
+           (code-bindings
+            (mapcar
+             #'(lambda (action-binding)
+                 (let ((action-symbol (car action-binding))
+                       (action (cdr action-binding)))
+                   (unless action
+                     (error "Missing action ~S for production ~S" (car action-binding) (production-name production)))
+                   (multiple-value-bind (has-type type) (action-declaration grammar (production-lhs production) action-symbol)
+                     (declare (ignore has-type))
+                     (let ((code (compute-action-code world production action-symbol (action-type action) (action-expr action) type initial-env))
+                           (result-var (gensym (symbol-name action-symbol))))
+                       (when *trace-variables*
+                         (format *trace-output* "~&~@<~S[~S] := ~2I~_~:W~:>~%" action-symbol (production-name production) code))
+                       (push result-var result-vars)
+                       (push (make-type-env-action
+                              (list* action-symbol (general-grammar-symbol-symbol lhs) 0)
+                              result-var
+                              type
+                              lhs)
+                             initial-env)
+                       (list result-var code)))))
+             (production-actions production)))
+           (filtered-args (mapcar #'(lambda (arg)
+                                      (and (tree-member arg code-bindings) arg))
+                                  args))
+           (production-code
+            (if code-bindings
+              `(lambda (stack)
+                 (list*-bind ,(nreconc filtered-args '(stack-rest)) stack
+                   (let* ,code-bindings
+                     (list* ,@result-vars stack-rest))))
+              `(lambda (stack)
+                 (nthcdr ,n-action-args stack))))
+           (production-code-name (unique-function-name world (string (production-name production)))))
+      (setf (production-n-action-args production) n-action-args)
+      (when *trace-variables*
+        (format *trace-output* "~&~@<all[~S] := ~2I~_~:W~:>~%" (production-name production) production-code))
+      (handler-bind (((or error warning)
+                      #'(lambda (condition)
+                          (declare (ignore condition))
+                          (format *error-output* "~&While computing production ~S:~%" (production-name production)))))
+        (quiet-compile production-code-name production-code)
+        (setf (production-evaluator production) (symbol-function production-code-name))))))
+
+
+; Return a list of all grammar symbols' symbols that are present in at least one expr-annotation:action
 ; in the annotated expression.  The symbols are returned in no particular order.
 (defun annotated-expr-grammar-symbols (annotated-expr)
   (let ((symbols nil))
@@ -3796,21 +3909,31 @@
 
 
 ; (<- <name> <value>)
-; Mutate the local variable.
+; Mutate the local or global variable.
 (defun scan-<- (world type-env rest-statements last special-form name value-expr)
   (let* ((symbol (scan-name world name))
-         (symbol-binding (type-env-get-local type-env symbol)))
+         (symbol-binding (type-env-get-local type-env symbol))
-    (unless symbol-binding
+         type)
-      (error "Unknown local variable ~A" name))
+    (if symbol-binding
-    (unless (eq (type-env-local-mode symbol-binding) :var)
+      (if (eq (type-env-local-mode symbol-binding) :var)
+        (setq type (type-env-local-type symbol-binding))
         (error "Local variable ~A not writable" name))
-    (multiple-value-bind (value-code value-annotated-expr) (scan-typed-value world type-env value-expr (type-env-local-type symbol-binding))
+      (progn
+        (setq type (symbol-type symbol))
+        (unless type
+          (error "Unknown local or global variable ~A" name))
+        (unless (get symbol :mutable)
+          (error "Global variable ~A not writable" name))))
+    (multiple-value-bind (value-code value-annotated-expr) (scan-typed-value world type-env value-expr type)
       (multiple-value-bind (rest-codes rest-live rest-annotated-stmts)
                            (scan-statements world type-env rest-statements last t)
         (values
-         (cons (list 'setq (type-env-local-name symbol-binding) value-code) rest-codes)
+         (cons (if symbol-binding
+                 (list 'setq (type-env-local-name symbol-binding) value-code)
+                 (list 'store-global-value symbol value-code))
+               rest-codes)
          rest-live
-         (cons (list special-form name value-annotated-expr) rest-annotated-stmts))))))
+         (cons (list special-form name value-annotated-expr (not symbol-binding)) rest-annotated-stmts))))))
 
 
 ; (&= <record-expr> <value-expr>)
@@ -3855,6 +3978,39 @@
              (cons (list special-form record-type label record-annotated-expr value-annotated-expr) rest-annotated-stmts))))))))
 
 
+; (action<- <action> <value>)
+; Mutate the writable action.  This can be done only once per action.
+(defun scan-action<- (world type-env rest-statements last special-form action value-expr)
+  (unless (and (consp action) (identifier? (first action)))
+    (error "Bad action: ~S" action))
+  (let ((symbol (world-intern world (first action))))
+    (unless (symbol-action symbol)
+      (error "~S is not an action name" (first action)))
+    (multiple-value-bind (action-value action-type action-annotated-expr) (apply #'scan-action-call type-env symbol (rest action))
+      (unless (eq (type-kind action-type) :writable-cell)
+        (error "action<- type ~S must be a writable-cell" action-type))
+      (assert-true (symbolp action-value))
+      (multiple-value-bind (value-code value-annotated-expr) (scan-typed-value world type-env value-expr (writable-cell-element-type action-type))
+        (multiple-value-bind (rest-codes rest-live rest-annotated-stmts)
+                             (scan-statements world type-env rest-statements last t)
+          (values
+           (if (or (symbolp value-code) (numberp value-code))
+             (list* `(when (car ,action-value)
+                       (error "Attempt to write ~S to an already initialized writable-cell ~S" ,value-code ,action-value))
+                    `(setf (car ,action-value) t)
+                    `(setf (cdr ,action-value) ,value-code)
+                    rest-codes)
+             (let ((v (gensym "V")))
+               (cons `(let ((,v ,value-code))
+                        (when (car ,action-value)
+                          (error "Attempt to write ~S to an already initialized writable-cell ~S" ,v ,action-value))
+                        (setf (car ,action-value) t)
+                        (setf (cdr ,action-value) ,v))
+                     rest-codes)))
+           rest-live
+           (cons (list special-form action-annotated-expr value-annotated-expr) rest-annotated-stmts)))))))
+
+
 ; (return [<value-expr>])
 (defun scan-return (world type-env rest-statements last special-form &optional value-expr)
   (let ((value-code nil)
@@ -4174,7 +4330,7 @@
 
 ; (define <name> <type> <value>)
 ; (defun <name> (-> (<type1> ... <typen>) <result-type>) (lambda ((<arg1> <type1>) ... (<argn> <typen>)) <result-type> . <statements>))
-; Create the variable in the world but do not evaluate its type or value yet.
+; Create the constant in the world but do not evaluate its type or value yet.
 (defun scan-define (world grammar-info-var name type-expr value-expr)
   (declare (ignore grammar-info-var))
   (let ((symbol (scan-name world name)))
@@ -4185,6 +4341,19 @@
     (export-symbol symbol)))
 
 
+; (defvar <name> <type> <value>)
+; Create the variable in the world but do not evaluate its type or value yet.
+(defun scan-defvar (world grammar-info-var name type-expr value-expr)
+  (declare (ignore grammar-info-var))
+  (let ((symbol (scan-name world name)))
+    (unless (eq (get symbol :value-expr *get2-nonce*) *get2-nonce*)
+      (error "Attempt to redefine variable ~A" symbol))
+    (setf (get symbol :value-expr) value-expr)
+    (setf (get symbol :type-expr) type-expr)
+    (setf (get symbol :mutable) t)
+    (export-symbol symbol)))
+
+
 ; (set-grammar <name>)
 ; Set the current grammar to the grammar or lexer with the given name.
 (defun scan-set-grammar (world grammar-info-var name)
@@ -4211,14 +4380,15 @@
 
 ; (declare-action <action-name> <general-grammar-symbol> <type> <mode> <parameter-list> <command> ... <command>)
 ; <mode> is one of:
-;    :hide      Don't depict this action declaration because it's for a hidden production
+;    :hide      Don't depict this action declaration because it's for a hidden production;
-;    :singleton Don't depict this action declaration because it contains a singleton production
+;    :singleton Don't depict this action declaration because it contains a singleton production;
 ;    :action    Depict this action declaration; all corresponding actions will be depicted by depict-action;
 ;    :actfun    Depict this action declaration; all corresponding actions will be depicted by depict-actfun;
+;    :writable  Depict this action declaration but not actions.
 ; <parameter-list> contains the names of the action parameters when <mode> is :actfun.
 (defun scan-declare-action (world grammar-info-var action-name general-grammar-symbol-source type-expr mode parameter-list &rest commands)
   (declare (ignore parameter-list))
-  (unless (member mode '(:hide :singleton :action :actfun))
+  (unless (member mode '(:hide :singleton :action :actfun :writable))
     (error "Bad declare-action mode ~S" mode))
   (let* ((grammar (checked-grammar grammar-info-var))
          (action-symbol (scan-name world action-name))
@@ -4235,9 +4405,9 @@
 ; <mode> is one of:
 ;    :hide      Don't depict this action;
 ;    :singleton Depict this action along with its declaration;
-;    :first     Depict this action, which is the first in the rule
+;    :first     Depict this action, which is the first in the rule;
-;    :middle    Depict this action, which is neither the first nor the last in the rule
+;    :middle    Depict this action, which is neither the first nor the last in the rule;
-;    :last      Depict this action, which is the last in the rule
+;    :last      Depict this action, which is the last in the rule.
 (defun scan-action (world grammar-info-var action-name production-name type-expr mode value-expr)
   (unless (member mode '(:hide :singleton :first :middle :last))
     (error "Bad action mode ~S" mode))
@@ -4285,6 +4455,7 @@
      (deftype scan-deftype depict-deftype)
      (define scan-define depict-define)
      (defun scan-define depict-defun)    ;Occurs from desugaring a function define
+     (defvar scan-defvar depict-defvar)
      (set-grammar scan-set-grammar depict-set-grammar)
      (clear-grammar scan-clear-grammar depict-clear-grammar)
      (declare-action scan-declare-action depict-declare-action)
@@ -4300,6 +4471,7 @@
      (function scan-function depict-function)
      (<- scan-<- depict-<-)
      (&= scan-&= depict-&=)
+     (action<- scan-action<- depict-action<-)
      (return scan-return depict-return)
      (rwhen scan-rwhen depict-cond)
      (when scan-when depict-cond)
@@ -4366,7 +4538,10 @@
      
      ;;Unions
      (in scan-in depict-in)
-     (not-in scan-not-in depict-not-in))
+     (not-in scan-not-in depict-not-in)
+     
+     ;;Writable Cells
+     (writable-cell-of scan-writable-cell-of depict-writable-cell-of)) ;For internal use only
     
     (:condition
      (not scan-not-condition)
@@ -4382,7 +4557,8 @@
      (list-set scan-list-set depict-set)
      (range-set scan-range-set depict-set)
      (tag scan-tag-type depict-tag-type)
-     (union scan-union depict-union))))
+     (union scan-union depict-union)
+     (writable-cell scan-writable-cell depict-writable-cell))))
 
 
 (defparameter *default-primitives*
@@ -4724,43 +4900,7 @@
     (each-grammar-production
      grammar
      #'(lambda (production)
-         (let* ((n-action-args (n-action-args grammar production))
+         (compute-production-code world grammar production)))))
-                (codes
-                 (mapcar
-                  #'(lambda (action-binding)
-                      (let ((action-symbol (car action-binding))
-                            (action (cdr action-binding)))
-                        (unless action
-                          (error "Missing action ~S for production ~S" (car action-binding) (production-name production)))
-                        (multiple-value-bind (has-type type) (action-declaration grammar (production-lhs production) action-symbol)
-                          (declare (ignore has-type))
-                          (let ((code (compute-action-code world grammar production action-symbol (action-type action) (action-expr action) type)))
-                            (setf (action-code action) code)
-                            (when *trace-variables*
-                              (format *trace-output* "~&~@<~S[~S] := ~2I~_~:W~:>~%" action-symbol (production-name production) code))
-                            code))))
-                  (production-actions production)))
-                (production-code
-                 (if codes
-                   (let* ((vars-and-rest (intern-n-vars-with-prefix "ARG" n-action-args '(stack-rest)))
-                          (vars (nreverse (butlast vars-and-rest)))
-                          (applied-codes (mapcar #'(lambda (code) (apply #'gen-apply code vars))
-                                                 (nreverse codes))))
-                     `(lambda (stack)
-                        (list*-bind ,vars-and-rest stack
-                          (list* ,@applied-codes stack-rest))))
-                   `(lambda (stack)
-                      (nthcdr ,n-action-args stack))))
-                (production-code-name (unique-function-name world (string (production-name production)))))
-           (setf (production-n-action-args production) n-action-args)
-           (when *trace-variables*
-             (format *trace-output* "~&~@<all[~S] := ~2I~_~:W~:>~%" (production-name production) production-code))
-           (handler-bind (((or error warning)
-                           #'(lambda (condition)
-                               (declare (ignore condition))
-                               (format *error-output* "~&While computing production ~S:~%" (production-name production)))))
-             (quiet-compile production-code-name production-code)
-             (setf (production-evaluator production) (symbol-function production-code-name))))))))
 
 
 ; Evaluate the given commands in the world.
@@ -5141,9 +5281,20 @@
   (assert-type action-declarations (list (tuple symbol t)))
   (preprocess-ensure-grammar preprocessor-state)
   (labels
-    ((actions-match (action-declarations parameter-lists actions)
+    ((writable-action (action-declaration)
+       (let ((type (second action-declaration)))
+         (and (consp type)
+              (eq (first type) 'writable-cell))))
+     
+     (actions-match (action-declarations parameter-lists actions)
        (or (and (endp action-declarations) (endp parameter-lists) (endp actions))
-           (let ((declared-action-name (caar action-declarations))
+           (let ((action-declaration (first action-declarations)))
+             (if (writable-action action-declaration)
+               (progn
+                 (when (eq (first parameter-lists) t)
+                   (setf (first parameter-lists) :value))
+                 (actions-match (rest action-declarations) (rest parameter-lists) actions))
+               (let ((declared-action-name (first action-declaration))
                      (action-name (caar actions))
                      (parameter-list :value))
                  (when (consp action-name)
@@ -5157,7 +5308,7 @@
                    (setf (first parameter-lists) parameter-list))
                  (and (eq declared-action-name action-name)
                       (equal (first parameter-lists) parameter-list)
-                  (actions-match (rest action-declarations) (rest parameter-lists) (rest actions)))))))
+                      (actions-match (rest action-declarations) (rest parameter-lists) (rest actions)))))))))
     
     (let* ((n-productions 0)
            (parameter-lists (make-list (length action-declarations) :initial-element t))
@@ -5180,10 +5331,12 @@
               (preprocessor-state-highlight preprocessor-state)))))
       (when (= n-productions 0)
         (error "Empty rule"))
-      (dotimes (i (length action-declarations))
+      (let ((i 4))
-        (let* ((action-declaration (pop action-declarations))
+        (dolist (action-declaration action-declarations)
-               (parameter-list (pop parameter-lists))
+          (let* ((parameter-list (pop parameter-lists))
+                 (writable (writable-action action-declaration))
                  (declare-mode (cond
+                                (writable :writable)
                                 ((= n-productions 1) :singleton)
                                 ((eq parameter-list :value) :action)
                                 (t (assert-true (listp parameter-list)) :actfun)))
@@ -5194,7 +5347,10 @@
                     #'(lambda (production highlight)
                         (declare (ignore highlight))
                         (let ((name (fourth production))
-                            (action (nth (+ i 4) production))
+                              (action (if writable
+                                        (list (first action-declaration)
+                                              (list 'writable-cell-of (second (second action-declaration))))
+                                        (nth i production)))
                               (mode (cond
                                      ((= n-productions 1) :singleton)
                                      ((= j 0) :first)
@@ -5206,8 +5362,10 @@
                     productions
                     (preprocessor-state-highlight preprocessor-state)))
                   commands-reverse)
-          (assert-true (= j n-productions))))
+            (assert-true (= j n-productions))
-      (values (nreverse commands-reverse) t))))
+            (unless writable
+              (incf i))))
+        (values (nreverse commands-reverse) t)))))
 
 
 ; (exclude <lhs> ... <lhs>)

js2/semantics/CalculusMarkup.lisp

@@ -331,6 +331,12 @@
                      :break 1)))))
 
 
+; (writable-cell <element-type>)
+;   "<element-type>"
+(defun depict-writable-cell (markup-stream world level element-type-expr)
+  (depict-type-expr markup-stream world element-type-expr level))
+
+
 ;;; ------------------------------------------------------------------------------------------------------
 ;;; DEPICTING EXPRESSIONS
 
@@ -906,6 +912,14 @@
   (depict-in-or-not-in markup-stream world level value-annotated-expr type type-expr :not-member-10 :not-equal))
 
 
+;;; Writable Cells
+
+; (writable-cell-of <element-type>)
+(defun depict-writable-cell-of (markup-stream world level)
+  (declare (ignore markup-stream world level))
+  (error "No notation to creation of a writable cell"))
+
+
 ;;; ------------------------------------------------------------------------------------------------------
 ;;; DEPICTING STATEMENTS
 
@@ -982,9 +996,11 @@
 
 
 ; (<- <name> <value>)
-(defun depict-<- (markup-stream world semicolon last-paragraph-style name value-annotated-expr)
+(defun depict-<- (markup-stream world semicolon last-paragraph-style name value-annotated-expr global)
   (depict-paragraph (markup-stream last-paragraph-style)
-    (depict-local-variable markup-stream name)
+    (if global
+      (depict-global-variable markup-stream name :reference)
+      (depict-local-variable markup-stream name))
     (depict markup-stream " " :assign-10)
     (depict-logical-block (markup-stream 6)
       (depict-break markup-stream 1)
@@ -1003,6 +1019,17 @@
       (depict-semicolon markup-stream semicolon))))
 
 
+; (action<- <action> <value>)
+(defun depict-action<- (markup-stream world semicolon last-paragraph-style action-annotated-expr value-annotated-expr)
+  (depict-paragraph (markup-stream last-paragraph-style)
+    (depict-expression markup-stream world action-annotated-expr %expr%)
+    (depict markup-stream " " :assign-10)
+    (depict-logical-block (markup-stream 6)
+      (depict-break markup-stream 1)
+      (depict-expression markup-stream world value-annotated-expr %expr%)
+      (depict-semicolon markup-stream semicolon))))
+
+
 ; (return [<value-expr>])
 (defun depict-return (markup-stream world semicolon last-paragraph-style value-annotated-expr)
   (depict-paragraph (markup-stream last-paragraph-style)
@@ -1414,10 +1441,10 @@
     (depict-type-expr markup-stream world type-expr)))
 
 
-(defun depict-equals-and-value (markup-stream world value-annotated-expr)
+(defun depict-equals-and-value (markup-stream world value-annotated-expr assignment)
   (depict-break markup-stream 1)
   (depict-logical-block (markup-stream 4)
-    (depict markup-stream "= ")
+    (depict markup-stream assignment " ")
     (depict-expression markup-stream world value-annotated-expr %expr%)
     (depict markup-stream ";")))
 
@@ -1449,7 +1476,19 @@
         (depict-logical-block (markup-stream 0)
           (depict-global-variable markup-stream name :definition)
           (depict-colon-and-type markup-stream world type-expr)
-          (depict-equals-and-value markup-stream world value-annotated-expr))))))
+          (depict-equals-and-value markup-stream world value-annotated-expr "="))))))
+
+
+; (defvar <name> <type> <value>)
+(defun depict-defvar (markup-stream world depict-env name type-expr value-expr)
+  (let ((value-annotated-expr (nth-value 2 (scan-value world *null-type-env* value-expr))))
+    (if (eq (car value-annotated-expr) 'expr-annotation:begin)
+      (error "defvar shouldn't use begin")
+      (depict-semantics (markup-stream depict-env)
+        (depict-logical-block (markup-stream 0)
+          (depict-global-variable markup-stream name :definition)
+          (depict-colon-and-type markup-stream world type-expr)
+          (depict-equals-and-value markup-stream world value-annotated-expr :assign-10))))))
 
 
 ; (defun <name> (-> (<type1> ... <typen>) <result-type>) (lambda ((<arg1> <type1>) ... (<argn> <typen>)) <result-type> . <statements>))
@@ -1524,10 +1563,11 @@
 
 ; (declare-action <action-name> <general-grammar-symbol> <type> <mode> <parameter-list> <command> ... <command>)
 ; <mode> is one of:
-;    :hide      Don't depict this action declaration because it's for a hidden production
+;    :hide      Don't depict this action declaration because it's for a hidden production;
-;    :singleton Don't depict this action declaration because it contains a singleton production
+;    :singleton Don't depict this action declaration because it contains a singleton production;
 ;    :action    Depict this action declaration; all corresponding actions will be depicted by depict-action;
 ;    :actfun    Depict this action declaration; all corresponding actions will be depicted by depict-actfun;
+;    :writable  Depict this action declaration but not actions.
 ; <parameter-list> contains the names of the action parameters when <mode> is :actfun.
 (defun depict-declare-action (markup-stream world depict-env action-name general-grammar-symbol-source type-expr mode parameter-list &rest commands)
   (let* ((grammar-info (checked-depict-env-grammar-info depict-env))
@@ -1563,7 +1603,12 @@
                (depict-paragraph (markup-stream :statement-last)
                  (depict-semantic-keyword markup-stream 'end :after)
                  (depict-semantic-keyword markup-stream 'proc nil)
-                 (depict markup-stream ";"))))))))))
+                 (depict markup-stream ";"))))))
+        (:writable
+         (depict-delayed-action (markup-stream depict-env action-name)
+           (depict-semantics (markup-stream depict-env)
+             (depict-declare-action-contents markup-stream world action-name general-grammar-symbol type-expr)
+             (depict markup-stream ";"))))))))
 
 
 ; Declare and define the lexer-action on the charclass given by nonterminal.
@@ -1617,7 +1662,7 @@
            (general-production (grammar-general-production grammar production-name))
            (lhs (general-production-lhs general-production)))
       (unless (hidden-nonterminal? lhs)
-        (let* ((initial-env (general-production-action-env grammar general-production))
+        (let* ((initial-env (general-production-action-env grammar general-production t))
                (type (scan-type world type-expr))
                (value-annotated-expr (nth-value 1 (scan-typed-value-or-begin world initial-env value-expr type)))
                (action-grammar-symbols (annotated-expr-grammar-symbols value-annotated-expr))
@@ -1660,7 +1705,7 @@
                       (depict-action-signature markup-stream action-name general-production action-grammar-symbols)
                       (when (eq mode :singleton)
                         (depict-colon-and-type markup-stream world type-expr))
-                      (depict-equals-and-value markup-stream world value-annotated-expr))))))))))))
+                      (depict-equals-and-value markup-stream world value-annotated-expr "="))))))))))))
 
 
 ; (terminal-action <action-name> <terminal> <lisp-function>)

js2/semantics/Grammar.lisp

@@ -155,8 +155,7 @@
 (defstruct (action (:constructor make-action (type expr))
                    (:predicate action?))
   (type nil :read-only t)                     ;The unparsed type of the action's result
-  (expr nil :read-only t)                     ;The unparsed source expression that defines the action
+  (expr nil :read-only t))                    ;The unparsed source expression that defines the action
-  (code nil))                                 ;The generated lisp source code that performs the action
 
 
 ;;; ------------------------------------------------------------------------------------------------------
@@ -300,11 +299,8 @@
 ; link is the lhs's link type.
 (defun depict-general-production (markup-stream general-production link &optional symbols-with-subscripts)
   (let ((lhs (general-production-lhs general-production))
-        (rhs-components (general-production-rhs-components general-production)))
+        (rhs-components (general-production-rhs-components general-production))
-    (depict-general-nonterminal markup-stream lhs link)
+        (counts-hash (make-hash-table :test *grammar-symbol-=*)))
-    (depict markup-stream " " :derives-10)
-    (if rhs-components
-      (let ((counts-hash (make-hash-table :test *grammar-symbol-=*)))
     (when symbols-with-subscripts
       (dolist (symbol symbols-with-subscripts)
         (setf (gethash symbol counts-hash) 0))
@@ -319,6 +315,9 @@
                      (setf (gethash symbol counts-hash) 0)
                      (remhash symbol counts-hash)))
                counts-hash))
+    (depict-general-nonterminal markup-stream lhs link (gethash (general-grammar-symbol-symbol lhs) counts-hash))
+    (depict markup-stream " " :derives-10)
+    (if rhs-components
       (dolist (production-rhs-component rhs-components)
         (let ((subscript nil))
           (when (general-grammar-symbol? production-rhs-component)
@@ -326,7 +325,7 @@
               (when (gethash symbol counts-hash)
                 (setq subscript (incf (gethash symbol counts-hash))))))
           (depict-space markup-stream)
-            (depict-production-rhs-component markup-stream production-rhs-component subscript))))
+          (depict-production-rhs-component markup-stream production-rhs-component subscript)))
       (depict markup-stream " " :left-angle-quote "empty" :right-angle-quote))))
 
 
@@ -1092,7 +1091,7 @@
   (items-hash nil :type (or null hash-table))            ;Hash table of (production . dot) -> item; nil for a cleaned grammar or a grammar without a parser
   (states nil :type list)                                ;List of LR(0) states (in order of state numbers)
   ;The following fields are used for the action generator.
-  (action-signatures nil :type (or null hash-table)))    ;Hash table of grammar-symbol -> list of (action-symbol . type-or-type-expr)
+  (action-signatures nil :type (or null hash-table)))    ;Hash table of grammar-symbol -> list of (action-symbol type-or-type-expr writable)
 
 
 ; Return a list of the given terminal's variants, including the terminal itself.