pjs/js2/semantics/CalculusMarkup.lisp

;;; The contents of this file are subject to the Netscape Public License
;;; Version 1.0 (the "NPL"); you may not use this file except in
;;; compliance with the NPL.  You may obtain a copy of the NPL at
;;; http://www.mozilla.org/NPL/
;;;
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
;;; for the specific language governing rights and limitations under the
;;; NPL.
;;;
;;; The Initial Developer of this code under the NPL is Netscape
;;; Communications Corporation.  Portions created by Netscape are
;;; Copyright (C) 1998 Netscape Communications Corporation.  All Rights
;;; Reserved.

;;;
;;; ECMAScript semantic calculus markup emitters
;;;
;;; Waldemar Horwat (waldemar@netscape.com)
;;;


;;; ------------------------------------------------------------------------------------------------------
;;; SEMANTIC DEPICTION UTILITIES

(defparameter *semantic-keywords*
  '(not and or is type oneof tuple action lambda if then else in new case of end let letexc))

; Emit markup for one of the semantic keywords, as specified by keyword-symbol.
(defun depict-semantic-keyword (markup-stream keyword-symbol)
  (assert-true (find keyword-symbol *semantic-keywords* :test #'eq))
  (depict-char-style (markup-stream :semantic-keyword)
    (depict markup-stream (string-downcase (symbol-name keyword-symbol)))))


; If test is true, depict an opening parenthesis, evaluate body, and depict a closing
; parentheses.  Otherwise, just evaluate body.
; Return the result value of body.
(defmacro depict-optional-parentheses ((markup-stream test) &body body)
  (let ((temp (gensym "PAREN")))
    `(let ((,temp ,test))
       (when ,temp
         (depict ,markup-stream "("))
       (prog1
         (progn ,@body)
         (when ,temp
           (depict ,markup-stream ")"))))))


;;; ------------------------------------------------------------------------------------------------------
;;; DEPICT-ENV

; A depict-env holds state that helps in depicting a grammar or lexer.
(defstruct depict-env
  (grammar-info nil :type (or null grammar-info))                ;The current grammar-info or nil if none
  (seen-nonterminals nil :type (or null hash-table))             ;Hash table (nonterminal -> t) of nonterminals already depicted
  (seen-grammar-arguments nil :type (or null hash-table))        ;Hash table (grammar-argument -> t) of grammar-arguments already depicted
  (mode nil :type (member nil :syntax :semantics))               ;Current heading (:syntax or :semantics) or nil if none
  (pending-actions-reverse nil :type list))                      ;Reverse-order list of closures of actions pending for a %print-actions


(defun checked-depict-env-grammar-info (depict-env)
  (or (depict-env-grammar-info depict-env)
      (error "Grammar needed")))


(defvar *visible-modes* t)

; Set the mode to the given mode, emitting a heading if necessary.
(defun depict-mode (markup-stream depict-env mode)
  (unless (eq mode (depict-env-mode depict-env))
    (when *visible-modes*
      (ecase mode
        (:syntax (depict-paragraph (markup-stream ':grammar-header)
                   (depict markup-stream "Syntax")))
        (:semantics (depict-paragraph (markup-stream ':grammar-header)
                      (depict markup-stream "Semantics")))
        ((nil))))
    (setf (depict-env-mode depict-env) mode)))


; Emit markup paragraphs for a command.
(defun depict-command (markup-stream world depict-env command)
  (handler-bind ((error #'(lambda (condition)
                            (declare (ignore condition))
                            (format *error-output* "~&While depicting: ~:W~%" command))))
    (let ((depictor (and (consp command)
                         (identifier? (first command))
                         (get (world-intern world (first command)) :depict-command))))
      (if depictor
        (apply depictor markup-stream world depict-env (rest command))
        (error "Bad command: ~S" command)))))


; Emit markup paragraphs for the world's commands.
(defun depict-world-commands (markup-stream world)
  (let ((depict-env (make-depict-env)))
    (dolist (command (world-commands-source world))
      (depict-command markup-stream world depict-env command))
    (depict-clear-grammar markup-stream world depict-env)))


;;; ------------------------------------------------------------------------------------------------------
;;; DEPICTING TYPES

(defconstant *type-level-min* 0)
(defconstant *type-level-suffix* 1)
(defconstant *type-level-function* 2)
(defconstant *type-level-max* 2)
;;;
;;; The level argument indicates what kinds of component types may be represented without being placed
;;; in parentheses.
;;;  level    kinds
;;;    0      id, oneof, tuple, (type)
;;;    1      id, oneof, tuple, (type), type[], type^
;;;    2      id, oneof, tuple, (type), type[], type^, type x type -> type


; Emit markup for the name of a type, which must be a symbol.
(defun depict-type-name (markup-stream type-name)
  (depict-char-style (markup-stream :type-name)
    (depict markup-stream (symbol-upper-mixed-case-name type-name))))


; Emit markup for the name of a tuple or oneof field, which must be a symbol.
(defun depict-field-name (markup-stream field-name)
  (depict-char-style (markup-stream :field-name)
    (depict markup-stream (symbol-lower-mixed-case-name field-name))))


; If level < threshold, depict an opening parenthesis, evaluate body, and depict a closing
; parentheses.  Otherwise, just evaluate body.
; Return the result value of body.
(defmacro depict-type-parentheses ((markup-stream level threshold) &body body)
  `(depict-optional-parentheses (,markup-stream (< ,level ,threshold))
     ,@body))


; Emit markup for the given type expression.  level is non-nil if this is a recursive
; call to depict-type-expr for which the markup-stream's style is :type-expression.
; In this case level indicates the binding level imposed by the enclosing type expression.
(defun depict-type-expr (markup-stream world type-expr &optional level)
  (cond
   ((identifier? type-expr)
    (depict-type-name markup-stream type-expr))
   ((type? type-expr)
    (let ((type-str (print-type-to-string type-expr)))
      (warn "Depicting raw type ~A" type-str)
      (depict markup-stream "<<<" type-str ">>>")))
   (t (let ((depictor (get (world-intern world (first type-expr)) :depict-type-constructor)))
        (if level
          (apply depictor markup-stream world level (rest type-expr))
          (depict-char-style (markup-stream :type-expression)
            (apply depictor markup-stream world *type-level-max* (rest type-expr))))))))


; (-> (<arg-type1> ... <arg-typen>) <result-type>)
; Level 2
;   "<arg-type1>@1 x ... x <arg-typen>@1 -> <result-type>@1"
(defun depict--> (markup-stream world level arg-type-exprs result-type-expr)
  (depict-type-parentheses (markup-stream level *type-level-function*)
    (depict-list markup-stream
                 #'(lambda (markup-stream arg-type-expr)
                     (depict-type-expr markup-stream world arg-type-expr *type-level-suffix*))
                 arg-type-exprs
                 :separator '(" " :cartesian-product-10 " ")
                 :empty "()")
    (depict markup-stream " " :function-arrow-10 " ")
    (depict-type-expr markup-stream world result-type-expr *type-level-suffix*)))


; (vector <element-type>)
; Level 1
;   "<element-type>@1[]"
(defun depict-vector (markup-stream world level element-type-expr)
  (depict-type-parentheses (markup-stream level *type-level-suffix*)
    (depict-type-expr markup-stream world element-type-expr *type-level-suffix*)
    (depict markup-stream "[]")))


; (address <element-type>)
; Level 1
;   "<element-type>@1^"
(defun depict-address (markup-stream world level element-type-expr)
  (depict-type-parentheses (markup-stream level *type-level-suffix*)
    (depict-type-expr markup-stream world element-type-expr *type-level-suffix*)
    (depict markup-stream :up-arrow-10)))


(defun depict-tuple-or-oneof (markup-stream world keyword-symbol tag-pairs)
  (depict-semantic-keyword markup-stream keyword-symbol)
  (depict-list
   markup-stream
   #'(lambda (markup-stream tag-pair)
       (if (identifier? tag-pair)
         (depict-field-name markup-stream tag-pair)
         (progn
           (depict-field-name markup-stream (first tag-pair))
           (depict markup-stream ": ")
           (depict-type-expr markup-stream world (second tag-pair) *type-level-function*))))
   tag-pairs
   :indent 6
   :prefix " {"
   :prefix-break 0
   :suffix "}"
   :separator ";"
   :break 1
   :empty nil))

; (oneof (<tag1> <type1>) ... (<tagn> <typen>))
; Level 0
;   "ONEOF{<tag1>: <type1>@0; ...; <tagn>:<typen>@0}"
(defun depict-oneof (markup-stream world level &rest tags-and-types)
  (declare (ignore level))
  (depict-tuple-or-oneof markup-stream world 'oneof tags-and-types))

; (tuple (<tag1> <type1>) ... (<tagn> <typen>))
; Level 0
;   "TUPLE{<tag1>: <type1>@0; ...; <tagn>:<typen>@0}"
(defun depict-tuple (markup-stream world level &rest tags-and-types)
  (declare (ignore level))
  (depict-tuple-or-oneof markup-stream world 'tuple tags-and-types))


;;; ------------------------------------------------------------------------------------------------------
;;; DEPICTING EXPRESSIONS


(defconstant *primitive-level-min* 0)
(defconstant *primitive-level-unary-suffix* 1)
(defconstant *primitive-level-unary-prefix* 2)
(defconstant *primitive-level-unary* 3)
(defconstant *primitive-level-multiplicative* 4)
(defconstant *primitive-level-additive* 5)
(defconstant *primitive-level-relational* 6)
(defconstant *primitive-level-logical* 7)
(defconstant *primitive-level-unparenthesized-new* 8)
(defconstant *primitive-level-expr* 9)
(defconstant *primitive-level-stmt* 10)
(defconstant *primitive-level-max* 10)
;;;
;;; The level argument indicates what kinds of subexpressions may be represented without being placed
;;; in parentheses (or on a separate line for the case of lambda and if/then/else).
;;;  level    kinds
;;;    0      id, constant, (e)
;;;    1      id, constant, (e), f(...), new(v), a[i]
;;;    2      id, constant, (e), -e, @
;;;    3      id, constant, (e), f(...), new(v), a[i], -e, @
;;;    4      id, constant, (e), f(...), new(v), a[i], -e, @, /, *
;;;    5      id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -
;;;    6      id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals
;;;    7      id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals
;;;    8      id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals, new v
;;;    9      id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals, new v
;;;   10      id, constant, (e), f(...), new(v), a[i], -e, @, /, *, +, -, relationals, logicals, new v, :=, lambda, if/then/else

; Return true if primitive-level1 is a superset of primitive-level2
; in the partial order of primitive levels.
(defun primitive-level->= (primitive-level1 primitive-level2)
  (and (>= primitive-level1 primitive-level2)
       (or (/= primitive-level1 *primitive-level-unary-prefix*)
           (/= primitive-level2 *primitive-level-unary-suffix*))))


; If primitive-level is not a superset of threshold, depict an opening parenthesis,
; evaluate body, and depict a closing parentheses.  Otherwise, just evaluate body.
; Return the result value of body.
(defmacro depict-expr-parentheses ((markup-stream primitive-level threshold) &body body)
  `(depict-optional-parentheses (,markup-stream (not (primitive-level->= ,primitive-level ,threshold)))
     ,@body))


; Emit markup for the name of a global variable, which must be a symbol.
(defun depict-global-variable (markup-stream name)
  (depict-char-style (markup-stream :global-variable)
    (depict markup-stream (symbol-lower-mixed-case-name name))))


; Emit markup for the name of a local variable, which must be a symbol.
(defun depict-local-variable (markup-stream name)
  (depict-char-style (markup-stream :local-variable)
    (depict markup-stream (symbol-lower-mixed-case-name name))))


; Emit markup for the name of an action, which must be a symbol.
(defun depict-action-name (markup-stream action-name)
  (depict-char-style (markup-stream :action-name)
    (depict markup-stream (symbol-upper-mixed-case-name action-name))))


; Emit markup for the value constant.
(defun depict-constant (markup-stream constant)
  (cond
   ((integerp constant)
    (depict-integer markup-stream constant))
   ((floatp constant)
    (depict markup-stream (format nil (if (= constant (floor constant 1)) "~,1F" "~F") constant)))
   ((characterp constant)
    (depict markup-stream ':left-single-quote)
    (depict-char-style (markup-stream ':character-literal)
      (depict-character markup-stream constant nil))
    (depict markup-stream ':right-single-quote))
   ((stringp constant)
    (depict-string markup-stream constant))
   (t (error "Bad constant ~S" constant))))


; Emit markup for the primitive when it is not called in a function call.
(defun depict-primitive (markup-stream primitive)
  (unless (eq (primitive-appearance primitive) ':global)
    (error "Can't depict primitive ~S outside a call" primitive))
  (depict-item-or-group-list markup-stream (primitive-markup1 primitive)))


; Emit markup for the parameters to a function call.
(defun depict-call-parameters (markup-stream world annotated-parameters)
  (depict-list markup-stream
               #'(lambda (markup-stream parameter)
                   (depict-annotated-value-expr markup-stream world parameter))
               annotated-parameters
               :indent 4
               :prefix "("
               :prefix-break 0
               :suffix ")"
               :separator ","
               :break 1
               :empty nil))


; Emit markup for the function or primitive call.  level indicates the binding level imposed
; by the enclosing expression.
(defun depict-call (markup-stream world level annotated-function-expr &rest annotated-arg-exprs)
  (if (eq (first annotated-function-expr) 'expr-annotation:primitive)
    (let ((primitive (symbol-primitive (second annotated-function-expr))))
      (depict-expr-parentheses (markup-stream level (primitive-level primitive))
        (ecase (primitive-appearance primitive)
          (:global
           (depict-primitive markup-stream primitive)
           (depict-call-parameters markup-stream world annotated-arg-exprs))
          (:infix
           (assert-true (= (length annotated-arg-exprs) 2))
           (depict-logical-block (markup-stream 0)
             (depict-annotated-value-expr markup-stream world (first annotated-arg-exprs) (primitive-level1 primitive))
             (let ((spaces (primitive-markup2 primitive)))
               (when spaces
                 (depict-space markup-stream))
               (depict-item-or-group-list markup-stream (primitive-markup1 primitive))
               (depict-break markup-stream (if spaces 1 0)))
             (depict-annotated-value-expr markup-stream world (second annotated-arg-exprs) (primitive-level2 primitive))))
          (:unary
           (assert-true (= (length annotated-arg-exprs) 1))
           (depict-item-or-group-list markup-stream (primitive-markup1 primitive))
           (depict-annotated-value-expr markup-stream world (first annotated-arg-exprs) (primitive-level1 primitive))
           (depict-item-or-group-list markup-stream (primitive-markup2 primitive)))
          (:phantom
           (assert-true (= (length annotated-arg-exprs) 1))
           (depict-annotated-value-expr markup-stream world (first annotated-arg-exprs) level)))))
    (depict-expr-parentheses (markup-stream level *primitive-level-unary-suffix*)
      (depict-annotated-value-expr markup-stream world annotated-function-expr *primitive-level-unary-suffix*)
      (depict-call-parameters markup-stream world annotated-arg-exprs))))


; 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)
  (depict-action-name markup-stream action-name)
  (depict markup-stream :action-begin)
  (depict-general-grammar-symbol markup-stream general-grammar-symbol index)
  (depict markup-stream :action-end))


; Emit markup for the given annotated value expression.  level indicates the binding level imposed
; by the enclosing expression.
(defun depict-annotated-value-expr (markup-stream world annotated-expr &optional (level *primitive-level-expr*))
  (let ((annotation (first annotated-expr))
        (args (rest annotated-expr)))
    (ecase annotation
      (expr-annotation:constant (depict-constant markup-stream (first args)))
      (expr-annotation:primitive (depict-primitive markup-stream (symbol-primitive (first args))))
      (expr-annotation:local (depict-local-variable markup-stream (first args)))
      (expr-annotation:global (depict-global-variable markup-stream (first args)))
      (expr-annotation:call (apply #'depict-call markup-stream world level args))
      (expr-annotation:action (apply #'depict-action-reference markup-stream args))
      (expr-annotation:special-form
       (apply (get (first args) :depict-special-form) markup-stream world level (rest args)))
      (expr-annotation:macro
       (let ((depictor (get (first args) :depict-macro)))
         (if depictor
           (apply depictor markup-stream world level (rest args))
           (depict-annotated-value-expr markup-stream world (second args) level)))))))


;;; ------------------------------------------------------------------------------------------------------
;;; DEPICTING SPECIAL FORMS

(defmacro depict-statement ((markup-stream keyword &optional (space t)) &body body)
  `(depict-logical-block (,markup-stream 0)
     (when (< level *primitive-level-stmt*)
       (depict-break ,markup-stream))
     (depict-expr-parentheses (,markup-stream level *primitive-level-stmt*)
       (depict-semantic-keyword ,markup-stream ,keyword)
       ,@(and space `((depict-space ,markup-stream)))
       ,@body)))


; (bottom <type>)
(defun depict-bottom (markup-stream world level type-expr)
  (declare (ignore world level type-expr))
  (depict markup-stream ':bottom-10))


(defun depict-lambda-bindings (markup-stream world arg-binding-exprs)
  (depict-list markup-stream
               #'(lambda (markup-stream arg-binding)
                   (depict-local-variable markup-stream (first arg-binding))
                   (depict markup-stream ": ")
                   (depict-type-expr markup-stream world (second arg-binding)))
               arg-binding-exprs
               :prefix "("
               :suffix ")"
               :separator ", "
               :empty nil))

; (lambda ((<var1> <type1> [:unused]) ... (<varn> <typen> [:unused])) <body>)
(defun depict-lambda (markup-stream world level arg-binding-exprs body-annotated-expr)
  (depict-statement (markup-stream 'lambda nil)
    (depict-lambda-bindings markup-stream world arg-binding-exprs)
    (depict-logical-block (markup-stream 4)
      (depict-break markup-stream)
      (depict-annotated-value-expr markup-stream world body-annotated-expr *primitive-level-stmt*))))


; (if <condition-expr> <true-expr> <false-expr>)
(defun depict-if (markup-stream world level condition-annotated-expr true-annotated-expr false-annotated-expr)
  (depict-statement (markup-stream 'if)
    (depict-logical-block (markup-stream 4)
      (depict-annotated-value-expr markup-stream world condition-annotated-expr))
    (depict-break markup-stream)
    (depict-semantic-keyword markup-stream 'then)
    (depict-space markup-stream)
    (depict-logical-block (markup-stream 7)
      (depict-annotated-value-expr markup-stream world true-annotated-expr *primitive-level-stmt*))
    (depict-break markup-stream)
    (depict-semantic-keyword markup-stream 'else)
    (depict-space markup-stream)
    (depict-logical-block (markup-stream (if (special-form-annotated-expr? 'if false-annotated-expr) nil 6))
      (depict-annotated-value-expr markup-stream world false-annotated-expr *primitive-level-stmt*))))


;;; Vectors

; (vector <element-expr> <element-expr> ... <element-expr>)
(defun depict-vector-form (markup-stream world level &rest element-annotated-exprs)
  (declare (ignore level))
  (depict-list markup-stream
               #'(lambda (markup-stream element-annotated-expr)
                   (depict-annotated-value-expr markup-stream world element-annotated-expr))
               element-annotated-exprs
               :indent 1
               :prefix ':vector-begin
               :suffix ':vector-end
               :separator ","
               :break 1))


(defun depict-subscript-type-expr (markup-stream world type-expr)
  (depict-char-style (markup-stream 'sub)
    (depict-type-expr markup-stream world type-expr)))


; (vector-of <element-type>)
(defun depict-vector-of (markup-stream world level element-type-expr)
  (declare (ignore level))
  (depict markup-stream ':empty-vector)
  (depict-subscript-type-expr markup-stream world element-type-expr))


(defun depict-special-function (markup-stream world name-str &rest arg-annotated-exprs)
  (depict-char-style (markup-stream :global-variable)
    (depict markup-stream name-str))
  (depict-call-parameters markup-stream world arg-annotated-exprs))


; (empty <vector-expr>)
(defun depict-empty (markup-stream world level vector-annotated-expr)
  (declare (ignore level))
  (depict-special-function markup-stream world "empty" vector-annotated-expr))


; (length <vector-expr>)
(defun depict-length (markup-stream world level vector-annotated-expr)
  (declare (ignore level))
  (depict-special-function markup-stream world "length" vector-annotated-expr))


; (first <vector-expr>)
(defun depict-first (markup-stream world level vector-annotated-expr)
  (declare (ignore level))
  (depict-special-function markup-stream world "first" vector-annotated-expr))


; (last <vector-expr>)
(defun depict-last (markup-stream world level vector-annotated-expr)
  (declare (ignore level))
  (depict-special-function markup-stream world "last" vector-annotated-expr))


; (rest <vector-expr>)
(defun depict-rest (markup-stream world level vector-annotated-expr)
  (declare (ignore level))
  (depict-special-function markup-stream world "rest" vector-annotated-expr))


; (butlast <vector-expr>)
(defun depict-butlast (markup-stream world level vector-annotated-expr)
  (declare (ignore level))
  (depict-special-function markup-stream world "butLast" vector-annotated-expr))


; (nth <vector-expr> <n-expr>)
(defun depict-nth (markup-stream world level vector-annotated-expr n-annotated-expr)
  (depict-expr-parentheses (markup-stream level *primitive-level-unary-suffix*)
    (depict-annotated-value-expr markup-stream world vector-annotated-expr *primitive-level-unary-suffix*)
    (depict markup-stream "[")
    (depict-annotated-value-expr markup-stream world n-annotated-expr)
    (depict markup-stream "]")))


; (append <vector-expr> <vector-expr>)
(defun depict-append (markup-stream world level vector1-annotated-expr vector2-annotated-expr)
  (depict-expr-parentheses (markup-stream level *primitive-level-additive*)
    (depict-logical-block (markup-stream 0)
      (depict-annotated-value-expr markup-stream world vector1-annotated-expr *primitive-level-additive*)
      (depict markup-stream " " :vector-append)
      (depict-break markup-stream 1)
      (depict-annotated-value-expr markup-stream world vector2-annotated-expr *primitive-level-additive*))))


;;; Oneofs

; (oneof <oneof-type> <tag> <value-expr>)
(defun depict-oneof-form (markup-stream world level tag &optional value-annotated-expr)
  (depict-expr-parentheses (markup-stream level *primitive-level-unary-prefix*)
    (depict-field-name markup-stream tag)
    (when value-annotated-expr
      (depict-logical-block (markup-stream 4)
        (depict-break markup-stream 1)
        (depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-unary*)))))


; (typed-oneof <type-expr> <tag> <value-expr>)
(defun depict-typed-oneof (markup-stream world level type-expr tag &optional value-annotated-expr)
  (depict-expr-parentheses (markup-stream level *primitive-level-unary-prefix*)
    (depict-field-name markup-stream tag)
    (depict-subscript-type-expr markup-stream world type-expr)
    (when value-annotated-expr
      (depict-logical-block (markup-stream 4)
        (depict-break markup-stream 1)
        (depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-unary*)))))


; (case <oneof-expr> (<tag-spec> <value-expr>) (<tag-spec> <value-expr>) ... (<tag-spec> <value-expr>))
; where each <tag-spec> is either ((<tag> <tag> ... <tag>) nil nil) or ((<tag>) <var> <type>)
(defun depict-case (markup-stream world level oneof-annotated-expr &rest annotated-cases)
  (depict-statement (markup-stream 'case)
    (depict-logical-block (markup-stream 6)
      (depict-annotated-value-expr markup-stream world oneof-annotated-expr))
    (depict-space markup-stream)
    (depict-semantic-keyword markup-stream 'of)
    (depict-logical-block (markup-stream 3)
      (mapl #'(lambda (annotated-cases)
                (let* ((annotated-case (first annotated-cases))
                       (tag-spec (first annotated-case))
                       (tags (first tag-spec))
                       (var (second tag-spec))
                       (value-annotated-expr (second annotated-case)))
                  (depict-break markup-stream)
                  (depict-logical-block (markup-stream 6)
                    (depict-list markup-stream
                                 #'depict-field-name
                                 tags
                                 :indent 0
                                 :separator ","
                                 :break 1)
                    (when var
                      (depict markup-stream "(")
                      (depict-local-variable markup-stream var)
                      (depict markup-stream ": ")
                      (depict-type-expr markup-stream world (third tag-spec))
                      (depict markup-stream ")"))
                    (depict markup-stream ":")
                    (depict-break markup-stream 1)
                    (depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-stmt*)
                    (when (cdr annotated-cases)
                      (depict markup-stream ";")))))
            annotated-cases)
      (depict-break markup-stream)
      (depict-semantic-keyword markup-stream 'end))))


; (select <tag> <oneof-expr>)
; (& <tag> <tuple-expr>)
(defun depict-select-or-& (markup-stream world level tag annotated-expr)
  (depict-expr-parentheses (markup-stream level *primitive-level-unary-suffix*)
    (depict-annotated-value-expr markup-stream world annotated-expr *primitive-level-unary-suffix*)
    (depict markup-stream ".")
    (depict-field-name markup-stream tag)))


; (is <tag> <oneof-expr>)
(defun depict-is (markup-stream world level tag oneof-annotated-expr)
  (depict-expr-parentheses (markup-stream level *primitive-level-relational*)
    (depict-annotated-value-expr markup-stream world oneof-annotated-expr *primitive-level-unary-suffix*)
    (depict-space markup-stream)
    (depict-semantic-keyword markup-stream 'is)
    (depict-space markup-stream)
    (depict-field-name markup-stream tag)))


;;; Tuples

; (tuple <tuple-type> <field-expr1> ... <field-exprn>)
(defun depict-tuple-form (markup-stream world level type-expr &rest annotated-exprs)
  (declare (ignore level))
  (depict-list markup-stream
               #'(lambda (markup-stream parameter)
                   (depict-annotated-value-expr markup-stream world parameter))
               annotated-exprs
               :indent 4
               :prefix ':tuple-begin
               :prefix-break 0
               :suffix ':tuple-end
               :separator ","
               :break 1
               :empty nil)
  (depict-subscript-type-expr markup-stream world type-expr))


;;; Addresses

; (new <value-expr>)
(defun depict-new (markup-stream world level value-annotated-expr)
  (depict-logical-block (markup-stream 5)
    (depict-semantic-keyword markup-stream 'new)
    (depict-space markup-stream)
    (depict-expr-parentheses (markup-stream level *primitive-level-unparenthesized-new*)
      (depict-annotated-value-expr markup-stream world value-annotated-expr
                                   (if (< level *primitive-level-unparenthesized-new*)
                                     *primitive-level-expr*
                                     *primitive-level-unary-prefix*)))))


; (@ <address-expr>)
(defun depict-@ (markup-stream world level address-annotated-expr)
  (depict-expr-parentheses (markup-stream level *primitive-level-unary-prefix*)
    (depict-logical-block (markup-stream 2)
      (depict markup-stream "@")
      (depict-annotated-value-expr markup-stream world address-annotated-expr *primitive-level-unary-prefix*))))


; (@= <address-expr> <value-expr>)
(defun depict-@= (markup-stream world level address-annotated-expr value-annotated-expr)
  (depict-expr-parentheses (markup-stream level *primitive-level-stmt*)
    (depict-logical-block (markup-stream 0)
      (depict markup-stream "@")
      (depict-annotated-value-expr markup-stream world address-annotated-expr *primitive-level-unary-prefix*)
      (depict markup-stream " :=")
      (depict-logical-block (markup-stream 6)
        (depict-break markup-stream 1)
        (depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-stmt*)))))


; (address-equal <address-expr1> <address-expr2>)
(defun depict-address-equal (markup-stream world level address1-annotated-expr address2-annotated-expr)
  (depict-expr-parentheses (markup-stream level *primitive-level-relational*)
    (depict-logical-block (markup-stream 0)
      (depict-annotated-value-expr markup-stream world address1-annotated-expr *primitive-level-additive*)
      (depict markup-stream " " :identical-10)
      (depict-break markup-stream 1)
      (depict-annotated-value-expr markup-stream world address2-annotated-expr *primitive-level-additive*))))


;;; Macros

(defun depict-let-binding (markup-stream world var type-expr value-annotated-expr)
  (depict-logical-block (markup-stream 4)
    (depict-local-variable markup-stream var)
    (depict markup-stream ": ")
    (depict-type-expr markup-stream world type-expr)
    (depict-break markup-stream 1)
    (depict-logical-block (markup-stream 3)
      (depict markup-stream "= ")
      (depict-annotated-value-expr markup-stream world value-annotated-expr *primitive-level-stmt*))))


(defun depict-let-body (markup-stream world body-annotated-expr)
  (depict-break markup-stream)
  (depict-semantic-keyword markup-stream 'in)
  (depict-space markup-stream)
  (depict-logical-block (markup-stream (if (or (macro-annotated-expr? 'let body-annotated-expr)
                                               (macro-annotated-expr? 'letexc body-annotated-expr))
                                         nil
                                         4))
    (depict-annotated-value-expr markup-stream world body-annotated-expr *primitive-level-stmt*)))


; (let ((<var1> <type1> <expr1> [:unused]) ... (<varn> <typen> <exprn> [:unused])) <body>)  ==>
; ((lambda ((<var1> <type1> [:unused]) ... (<varn> <typen> [:unused])) <body>) <expr1> ... <exprn>)
(defun depict-let (markup-stream world level annotated-expansion)
  (assert-true (eq (first annotated-expansion) 'expr-annotation:call))
  (let ((lambda-annotated-expr (second annotated-expansion))
        (arg-annotated-exprs (cddr annotated-expansion)))
    (assert-true (special-form-annotated-expr? 'lambda lambda-annotated-expr))
    (let ((arg-binding-exprs (third lambda-annotated-expr))
          (body-annotated-expr (fourth lambda-annotated-expr)))
      (depict-statement (markup-stream 'let)
        (depict-list markup-stream
                     #'(lambda (markup-stream arg-binding)
                         (depict-let-binding markup-stream world (first arg-binding) (second arg-binding) (pop arg-annotated-exprs)))
                     arg-binding-exprs
                     :indent 4
                     :separator ";"
                     :break t
                     :empty nil)
        (depict-let-body markup-stream world body-annotated-expr)))))


; (letexc (<var> <type> <expr> [:unused]) <body>)  ==>
; (case <expr>
;   ((abrupt x exception) (typed-oneof <body-type> abrupt x))
;   ((normal <var> <type> [:unused]) <body>)))
(defun depict-letexc (markup-stream world level annotated-expansion)
  (assert-true (special-form-annotated-expr? 'case annotated-expansion))
  (let* ((expr-annotated-expr (third annotated-expansion))
         (abrupt-binding (fourth annotated-expansion))
         (abrupt-tag-spec (first abrupt-binding))
         (normal-binding (fifth annotated-expansion))
         (normal-tag-spec (first normal-binding)))
    (assert-true (equal (first abrupt-tag-spec) '(abrupt)))
    (assert-true (equal (first normal-tag-spec) '(normal)))
    (let* ((var (second normal-tag-spec))
           (type-expr (third normal-tag-spec))
           (body-annotated-expr (second normal-binding)))
      (depict-statement (markup-stream 'letexc)
        (depict-logical-block (markup-stream 9)
          (depict-let-binding markup-stream world var type-expr expr-annotated-expr))
        (depict-let-body markup-stream world body-annotated-expr)))))


;;; ------------------------------------------------------------------------------------------------------
;;; DEPICTING COMMANDS


(defmacro depict-semantics ((markup-stream depict-env &optional (paragraph-style ':semantics)) &body body)
  `(progn
     (depict-mode ,markup-stream ,depict-env :semantics)
     (depict-paragraph (,markup-stream ,paragraph-style)
       ,@body)))


; (%section "section-name")
(defun depict-%section (markup-stream world depict-env section-name)
  (declare (ignore world))
  (assert-type section-name string)
  (depict-mode markup-stream depict-env nil)
  (depict-paragraph (markup-stream :section-heading)
    (depict markup-stream section-name)))


; (%subsection "subsection-name")
(defun depict-%subsection (markup-stream world depict-env section-name)
  (declare (ignore world))
  (assert-type section-name string)
  (depict-mode markup-stream depict-env nil)
  (depict-paragraph (markup-stream :subsection-heading)
    (depict markup-stream section-name)))


; (grammar-argument <argument> <attribute> <attribute> ... <attribute>)
(defun depict-grammar-argument (markup-stream world depict-env argument &rest attributes)
  (declare (ignore world))
  (let ((seen-grammar-arguments (depict-env-seen-grammar-arguments depict-env))
        (abbreviated-argument (symbol-abbreviation argument)))
    (unless (gethash abbreviated-argument seen-grammar-arguments)
      (depict-mode markup-stream depict-env :syntax)
      (depict-paragraph (markup-stream :grammar-argument)
        (depict-nonterminal-argument markup-stream argument)
        (depict markup-stream " " :member-10 " ")
        (depict-list markup-stream
                     #'(lambda (markup-stream attribute)
                         (depict-nonterminal-attribute markup-stream attribute))
                     attributes
                     :prefix "{"
                     :suffix "}"
                     :separator ", "))
      (setf (gethash abbreviated-argument seen-grammar-arguments) t))))


; (%rule <general-nonterminal-source>)
(defun depict-%rule (markup-stream world depict-env general-nonterminal-source)
  (declare (ignore world))
  (let* ((grammar-info (checked-depict-env-grammar-info depict-env))
         (grammar (grammar-info-grammar grammar-info))
         (general-nonterminal (grammar-parametrization-intern grammar general-nonterminal-source))
         (seen-nonterminals (depict-env-seen-nonterminals depict-env)))
    (when (grammar-info-charclass grammar-info general-nonterminal)
      (error "Shouldn't use %rule on a lexer charclass nonterminal ~S" general-nonterminal))
    (labels
      ((seen-nonterminal? (nonterminal)
         (gethash nonterminal seen-nonterminals)))
      (unless (every #'seen-nonterminal? (general-grammar-symbol-instances grammar general-nonterminal))
        (depict-mode markup-stream depict-env :syntax)
        (dolist (general-rule (grammar-general-rules grammar general-nonterminal))
          (let ((rule-lhs-nonterminals (general-grammar-symbol-instances grammar (general-rule-lhs general-rule))))
            (unless (every #'seen-nonterminal? rule-lhs-nonterminals)
              (when (some #'seen-nonterminal? rule-lhs-nonterminals)
                (warn "General rule for ~S listed before specific ones; use %rule to disambiguate" general-nonterminal))
              (depict-general-rule markup-stream general-rule)
              (dolist (nonterminal rule-lhs-nonterminals)
                (setf (gethash nonterminal seen-nonterminals) t)))))))))
;******** May still have a problem when a specific rule precedes a general one.


; (%charclass <nonterminal>)
(defun depict-%charclass (markup-stream world depict-env nonterminal)
  (let* ((grammar-info (checked-depict-env-grammar-info depict-env))
         (charclass (grammar-info-charclass grammar-info nonterminal)))
    (unless charclass
      (error "%charclass with a non-charclass ~S" nonterminal))
    (if (gethash nonterminal (depict-env-seen-nonterminals depict-env))
      (warn "Duplicate charclass ~S" nonterminal)
      (progn
        (depict-mode markup-stream depict-env :syntax)
        (depict-charclass markup-stream charclass)
        (dolist (action-cons (charclass-actions charclass))
          (depict-charclass-action world depict-env (cdr action-cons) nonterminal))
        (setf (gethash nonterminal (depict-env-seen-nonterminals depict-env)) t)))))


; (%print-actions)
(defun depict-%print-actions (markup-stream world depict-env)
  (declare (ignore world))
  (dolist (pending-action (nreverse (depict-env-pending-actions-reverse depict-env)))
    (funcall pending-action markup-stream depict-env))
  (setf (depict-env-pending-actions-reverse depict-env) nil))


; (deftype <name> <type>)
(defun depict-deftype (markup-stream world depict-env name type-expr)
  (depict-semantics (markup-stream depict-env)
    (depict-logical-block (markup-stream 2)
      (depict-semantic-keyword markup-stream 'type)
      (depict-space markup-stream)
      (depict-type-name markup-stream name)
      (depict-break markup-stream 1)
      (depict-logical-block (markup-stream 3)
        (depict markup-stream "= ")
        (depict-type-expr markup-stream world type-expr)))))


; (define <name> <type> <value> <destructured>)
; <destructured> is a flag that is true if this define was originally in the form
;   (define (<name> (<arg1> <type1>) ... (<argn> <typen>)) <result-type> <value>)
; and converted into
;   (define <name> (-> (<type1> ... <typen>) <result-type>)
;      (lambda ((<arg1> <type1>) ... (<argn> <typen>)) <value>)
;      t)
(defun depict-define (markup-stream world depict-env name type-expr value-expr destructured)
  (depict-semantics (markup-stream depict-env)
    (depict-logical-block (markup-stream 2)
      (depict-global-variable markup-stream name)
      (flet
        ((depict-type-and-value (markup-stream type-expr annotated-value-expr)
           (depict-logical-block (markup-stream 0)
             (depict-break markup-stream 1)
             (depict markup-stream ": ")
             (depict-type-expr markup-stream world type-expr))
           (depict-break markup-stream 1)
           (depict-logical-block (markup-stream 3)
             (depict markup-stream "= ")
             (depict-annotated-value-expr markup-stream world annotated-value-expr *primitive-level-max*))))
        
        (let ((annotated-value-expr (nth-value 2 (scan-value world *null-type-env* value-expr))))
          (if destructured
            (progn
              (assert-true (eq (first type-expr) '->))
              (assert-true (special-form-annotated-expr? 'lambda annotated-value-expr))
              (depict-lambda-bindings markup-stream world (third annotated-value-expr))
              (depict-type-and-value markup-stream (third type-expr) (fourth annotated-value-expr)))
            (depict-type-and-value markup-stream type-expr annotated-value-expr)))))))


; (set-grammar <name>)
(defun depict-set-grammar (markup-stream world depict-env name)
  (depict-clear-grammar markup-stream world depict-env)
  (let ((grammar-info (world-grammar-info world name)))
    (unless grammar-info
      (error "Unknown grammar ~A" name))
    (setf (depict-env-grammar-info depict-env) grammar-info)
    (setf (depict-env-seen-nonterminals depict-env) (make-hash-table :test #'eq))
    (setf (depict-env-seen-grammar-arguments depict-env) (make-hash-table :test #'eq))))


; (clear-grammar)
(defun depict-clear-grammar (markup-stream world depict-env)
  (depict-%print-actions markup-stream world depict-env)
  (depict-mode markup-stream depict-env nil)
  (let ((grammar-info (depict-env-grammar-info depict-env)))
    (when grammar-info
      (let ((seen-nonterminals (depict-env-seen-nonterminals depict-env))
            (missed-nonterminals nil))
        (dolist (nonterminal (grammar-nonterminals-list (grammar-info-grammar grammar-info)))
          (unless (or (gethash nonterminal seen-nonterminals)
                      (eq nonterminal *start-nonterminal*))
            (push nonterminal missed-nonterminals)))
        (when missed-nonterminals
          (warn "Nonterminals not printed: ~S" missed-nonterminals)))
      (setf (depict-env-grammar-info depict-env) nil)
      (setf (depict-env-seen-nonterminals depict-env) nil)
      (setf (depict-env-seen-grammar-arguments depict-env) nil))))


(defmacro depict-delayed-action ((markup-stream depict-env) &body depictor)
  `(push #'(lambda (,markup-stream ,depict-env) ,@depictor)
         (depict-env-pending-actions-reverse ,depict-env)))


(defun depict-declare-action-contents (markup-stream world action-name general-grammar-symbol type-expr)
  (depict-semantic-keyword markup-stream 'action)
  (depict-space markup-stream)
  (depict-action-name markup-stream action-name)
  (depict markup-stream :action-begin)
  (depict-general-grammar-symbol markup-stream general-grammar-symbol)
  (depict markup-stream :action-end)
  (depict-break markup-stream 1)
  (depict-logical-block (markup-stream 2)
    (depict markup-stream ": ")
    (depict-type-expr markup-stream world type-expr)))


; (declare-action <action-name> <general-grammar-symbol> <type>)
(defun depict-declare-action (markup-stream world depict-env action-name general-grammar-symbol-source type-expr)
  (declare (ignore markup-stream))
  (let* ((grammar-info (checked-depict-env-grammar-info depict-env))
         (general-grammar-symbol (grammar-parametrization-intern (grammar-info-grammar grammar-info) general-grammar-symbol-source)))
    (unless (grammar-info-charclass-or-partition grammar-info general-grammar-symbol)
      (depict-delayed-action (markup-stream depict-env)
        (depict-semantics (markup-stream depict-env)
          (depict-logical-block (markup-stream 4)
            (depict-declare-action-contents markup-stream world action-name general-grammar-symbol type-expr)))))))


; Declare and define the lexer-action on the charclass given by nonterminal.
(defun depict-charclass-action (world depict-env lexer-action nonterminal)
  (depict-delayed-action (markup-stream depict-env)
    (depict-semantics (markup-stream depict-env)
      (depict-logical-block (markup-stream 4)
        (depict-declare-action-contents markup-stream world (lexer-action-name lexer-action)
                                        nonterminal (lexer-action-type-expr lexer-action))
        (depict-break markup-stream 1)
        (depict-logical-block (markup-stream 3)
          (depict markup-stream "= ")
          (depict-lexer-action markup-stream lexer-action nonterminal))))))


; (action <action-name> <production-name> <body>)
; <destructured> is a flag that is true if this define was originally in the form
;   (action (<action-name> (<arg1> <type1>) ... (<argn> <typen>)) <production-name> <body>)
; and converted into
;   (action <action-name> <production-name> (lambda ((<arg1> <type1>) ... (<argn> <typen>)) <body>) t)
(defun depict-action (markup-stream world depict-env action-name production-name body-expr destructured)
  (declare (ignore markup-stream))
  (let* ((grammar-info (checked-depict-env-grammar-info depict-env))
         (grammar (grammar-info-grammar grammar-info))
         (general-production (grammar-general-production grammar production-name)))
    (unless (grammar-info-charclass grammar-info (general-production-lhs general-production))
      (depict-delayed-action (markup-stream depict-env)
        (depict-semantics (markup-stream depict-env :semantics-next)
          (depict-logical-block (markup-stream 2)
            (let* ((initial-env (general-production-action-env grammar general-production))
                   (body-annotated-expr (nth-value 2 (scan-value world initial-env body-expr)))
                   (action-grammar-symbols (annotated-expr-grammar-symbols body-annotated-expr)))
              (depict-action-name markup-stream action-name)
              (depict markup-stream :action-begin)
              (depict-general-production markup-stream general-production action-grammar-symbols)
              (depict markup-stream :action-end)
              (flet
                ((depict-body (markup-stream body-annotated-expr)
                   (depict-break markup-stream 1)
                   (depict-logical-block (markup-stream 3)
                     (depict markup-stream "= ")
                     (depict-annotated-value-expr markup-stream world body-annotated-expr *primitive-level-stmt*))))
                
                (if destructured
                  (progn
                    (assert-true (special-form-annotated-expr? 'lambda body-annotated-expr))
                    (depict-logical-block (markup-stream 10)
                      (depict-break markup-stream 0)
                      (depict-lambda-bindings markup-stream world (third body-annotated-expr)))
                    (depict-body markup-stream (fourth body-annotated-expr)))
                  (depict-body markup-stream body-annotated-expr))))))))))


; (terminal-action <action-name> <terminal> <lisp-function-name>)
(defun depict-terminal-action (markup-stream world depict-env action-name terminal function-name)
  (declare (ignore markup-stream world depict-env action-name terminal function-name)))