Magic-Mirror/gecko-dev
1
0
Fork 0
mirror of https://github.com/mozilla/gecko-dev.git synced 2025-02-18 14:56:07 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Added support for highlights.

Browse Source
This commit is contained in:
waldemar%netscape.com 2000-09-09 02:14:35 +00:00
parent 760079a091
commit 8f752abf38
14 changed files with 524 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

137
js/semantics/Calculus.lisp
View File

@ -26,7 +26,7 @@
(defvar *trace-variables* nil)
#+mcl (dolist (indent-spec '((apply . 1) (funcall . 1) (production . 3) (rule . 2) (function . 1) (letexc . 1) (deftype . 1) (tuple . 1) (%text . 1)))
#+mcl (dolist (indent-spec '((? . 1) (apply . 1) (funcall . 1) (production . 3) (rule . 2) (function . 1) (letexc . 1) (deftype . 1) (tuple . 1) (%text . 1)))
(pushnew indent-spec ccl:*fred-special-indent-alist* :test #'equal))
@ -426,6 +426,7 @@
(defstruct (world (:constructor allocate-world)
(:copier nil)
(:predicate world?))
(conditionals nil :type list) ;Assoc list of (conditional . highlight), where highlight can be a style keyword, nil (no style), or 'delete
(package nil :type package) ;The package in which this world's identifiers are interned
(n-type-names 0 :type integer) ;Number of type names defined so far
(types-reverse nil :type (or null hash-table)) ;Hash table of (kind tags parameters) -> type; nil if invalid
@ -577,6 +578,25 @@
(and grammar-info (grammar-info-lexer grammar-info))))
; Return a list of highlights allowed in this world.
(defun world-highlights (world)
(let ((highlights nil))
(dolist (c (world-conditionals world))
(let ((highlight (cdr c)))
(unless (or (null highlight) (eq highlight 'delete))
(pushnew highlight highlights))))
(nreverse highlights)))
; Return the highlight to which the given conditional maps.
; Return 'delete if the conditional should be omitted.
(defun resolve-conditional (world conditional)
(let ((h (assoc conditional (world-conditionals world))))
(if h
(cdr h)
(error "Bad conditional ~S" conditional))))
;;; ------------------------------------------------------------------------------------------------------
;;; SYMBOLS
@ -2327,6 +2347,13 @@
;;; ------------------------------------------------------------------------------------------------------
;;; COMMANDS
; (%highlight <highlight> <command> ... <command>)
; Evaluate the given commands. <highlight> is a hint for printing.
(defun scan-%highlight (world grammar-info-var highlight &rest commands)
(declare (ignore highlight))
(scan-commands world grammar-info-var commands))
; (%... ...)
; Ignore any command that starts with a %. These commands are hints for printing.
(defun scan-% (world grammar-info-var &rest rest)
@ -2415,6 +2442,7 @@
(defparameter *default-specials*
'((:preprocess
(? preprocess-?)
(define preprocess-define)
(action preprocess-action)
(grammar preprocess-grammar)
@ -2431,6 +2459,7 @@
(set-of expand-set-of nil))
(:command
(%highlight scan-%highlight depict-%highlight) ;For internal use only; use ? instead.
(%section scan-% depict-%section)
(%subsection scan-% depict-%subsection)
(%text scan-% depict-%text)
@ -2636,8 +2665,15 @@
; Create a world with the given name and set up the built-in properties of its symbols.
(defun init-world (name)
; conditionals is an association list of (conditional . highlight), where conditional is a symbol
; and highlight is either:
; a style keyword: Use that style to highlight the contents of any (? conditional ...) commands
; nil: Include the contents of any (? conditional ...) commands without highlighting them
; delete: Don't include the contents of (? conditional ...) commands
(defun init-world (name conditionals)
(assert-type conditionals (list (cons symbol (or null keyword (eql delete)))))
(let ((world (make-world name)))
(setf (world-conditionals world) conditionals)
(dolist (specials-list *default-specials*)
(let ((property (car specials-list)))
(dolist (special-spec (cdr specials-list))
@ -2753,10 +2789,8 @@
;;; ------------------------------------------------------------------------------------------------------
;;; EVALUATION
; Scan a command. Create types and variables in the world
; but do not evaluate variables' types or values yet.
; grammar-info-var is a cons cell whose car is either nil
; or a grammar-info for the grammar currently being defined.
; Scan a command. Create types and variables in the world but do not evaluate variables' types or values yet.
; grammar-info-var is a cons cell whose car is either nil or a grammar-info for the grammar currently being defined.
(defun scan-command (world grammar-info-var command)
(handler-bind ((error #'(lambda (condition)
(declare (ignore condition))
@ -2769,6 +2803,12 @@
(error "Bad command")))))
; Scan a list of commands. See scan-command above.
(defun scan-commands (world grammar-info-var commands)
(dolist (command commands)
(scan-command world grammar-info-var command)))
; Compute the primitives' types from their type-exprs.
(defun define-primitives (world)
(each-world-external-symbol-with-property
@ -2864,8 +2904,7 @@
(assert-true (null (world-commands-source world)))
(setf (world-commands-source world) commands)
(let ((grammar-info-var (list nil)))
(dolist (command commands)
(scan-command world grammar-info-var command)))
(scan-commands world grammar-info-var commands))
(unite-types world)
(setf (world-bottom-type world) (make-type world :bottom nil nil))
(setf (world-void-type world) (make-type world :void nil nil))
@ -2884,7 +2923,9 @@
;;; ------------------------------------------------------------------------------------------------------
;;; PREPROCESSING
(defstruct preprocessor-state
(defstruct (preprocessor-state (:constructor make-preprocessor-state (world)))
(world nil :type world :read-only t) ;The world into which preprocessed symbols are interned
(highlight nil :type symbol) ;The current highlight style or nil if none
(kind nil :type (member nil :grammar :lexer)) ;The kind of grammar being accumulated or nil if none
(kind2 nil :type (member nil :lalr-1 :lr-1 :canonical-lr-1)) ;The kind of parser
(name nil :type symbol) ;Name of the grammar being accumulated or nil if none
@ -2914,7 +2955,8 @@
(start-symbol (preprocessor-state-start-symbol preprocessor-state))
(grammar-source (nreverse (preprocessor-state-grammar-source-reverse preprocessor-state)))
(excluded-nonterminals-source (preprocessor-state-excluded-nonterminals-source preprocessor-state))
(grammar-options (preprocessor-state-grammar-options preprocessor-state)))
(grammar-options (preprocessor-state-grammar-options preprocessor-state))
(highlights (world-highlights (preprocessor-state-world preprocessor-state))))
(multiple-value-bind (grammar lexer extra-commands)
(ecase kind
(:grammar
@ -2924,6 +2966,7 @@
start-symbol
grammar-source
:excluded-nonterminals excluded-nonterminals-source
:highlights highlights
grammar-options)
nil
nil))
@ -2937,6 +2980,7 @@
start-symbol
grammar-source
:excluded-nonterminals excluded-nonterminals-source
:highlights highlights
grammar-options)
(values (lexer-grammar lexer) lexer extra-commands))))
(let ((grammar-info (make-grammar-info (preprocessor-state-name preprocessor-state) grammar lexer)))
@ -2954,19 +2998,17 @@
(append extra-commands (list '(clear-grammar)))))))))
; Helper function for preprocess-source.
; source is a list of preprocessor directives and commands. Preprocess these commands
; and return the following results:
; a list of preprocessed commands;
; a list of grammar-infos extracted from preprocessor directives.
(defun preprocess-source (world source)
(let ((preprocessor-state (make-preprocessor-state)))
(labels
; using the given preprocessor-state and return the resulting list of commands.
(defun preprocess-list (preprocessor-state source)
(let ((world (preprocessor-state-world preprocessor-state)))
(flet
((preprocess-one (form)
(when (consp form)
(let ((first (car form)))
(when (identifier? first)
(let* ((symbol (world-intern world first))
(action (symbol-preprocessor-function symbol)))
(let ((action (symbol-preprocessor-function (world-intern world first))))
(when action
(handler-bind ((error #'(lambda (condition)
(declare (ignore condition))
@ -2974,19 +3016,33 @@
(multiple-value-bind (preprocessed-form re-preprocess) (apply action preprocessor-state form)
(return-from preprocess-one
(if re-preprocess
(mapcan #'preprocess-one preprocessed-form)
(preprocess-list preprocessor-state preprocessed-form)
preprocessed-form)))))))))
(list form)))
(let* ((commands (mapcan #'preprocess-one source))
(commands (nconc commands (preprocessor-state-finish-grammar preprocessor-state))))
(values commands (nreverse (preprocessor-state-grammar-infos-reverse preprocessor-state)))))))
(mapcan #'preprocess-one source))))
; source is a list of preprocessor directives and commands. Preprocess these commands
; and return the following results:
; a list of preprocessed commands;
; a list of grammar-infos extracted from preprocessor directives.
(defun preprocess-source (world source)
(let* ((preprocessor-state (make-preprocessor-state world))
(commands (preprocess-list preprocessor-state source))
(commands (nconc commands (preprocessor-state-finish-grammar preprocessor-state))))
(values commands (nreverse (preprocessor-state-grammar-infos-reverse preprocessor-state)))))
; Create a new world with the given name and preprocess and evaluate the given
; source commands in it.
(defun generate-world (name source)
(let ((world (init-world name)))
; conditionals is an association list of (conditional . highlight), where conditional is a symbol
; and highlight is either:
; a style keyword: Use that style to highlight the contents of any (? conditional ...) commands
; nil: Include the contents of any (? conditional ...) commands without highlighting them
; delete: Don't include the contents of (? conditional ...) commands
(defun generate-world (name source &optional conditionals)
(let ((world (init-world name conditionals)))
(multiple-value-bind (commands grammar-infos) (preprocess-source world source)
(dolist (grammar-info grammar-infos)
(clear-actions (grammar-info-grammar grammar-info)))
@ -2999,6 +3055,27 @@
;;; PREPROCESSOR ACTIONS
; (? <conditional> <command> ... <command>)
; ==>
; (%highlight <highlight> <command> ... <command>)
; or
; <empty>
(defun preprocess-? (preprocessor-state command conditional &rest commands)
(declare (ignore command))
(let ((highlight (resolve-conditional (preprocessor-state-world preprocessor-state) conditional))
(saved-highlight (preprocessor-state-highlight preprocessor-state)))
(cond
((eq highlight 'delete) (values nil nil))
((eq highlight saved-highlight) (values commands t))
(t (values
(unwind-protect
(progn
(setf (preprocessor-state-highlight preprocessor-state) highlight)
(list (list* '%highlight highlight (preprocess-list preprocessor-state commands))))
(setf (preprocessor-state-highlight preprocessor-state) saved-highlight))
nil)))))
; (define <name> <type> <value>)
; ==>
; (define <name> <type> <value> nil)
@ -3123,7 +3200,7 @@
; (production <lhs> <rhs> <name> (<action-spec-1> <body-1>) ... (<action-spec-n> <body-n>))
; ==>
; grammar:
; (<lhs> <rhs> <name>)
; (<lhs> <rhs> <name> <current-highlight>)
; commands:
; (%rule <lhs>)
; (action <action-spec-1> <name> <body-1>)
@ -3133,7 +3210,8 @@
(declare (ignore command))
(assert-type actions (list (tuple t t)))
(preprocess-ensure-grammar preprocessor-state)
(push (list lhs rhs name) (preprocessor-state-grammar-source-reverse preprocessor-state))
(push (list lhs rhs name (preprocessor-state-highlight preprocessor-state))
(preprocessor-state-grammar-source-reverse preprocessor-state))
(values
(cons (list '%rule lhs)
(mapcar #'(lambda (action)
@ -3149,9 +3227,9 @@
; (production <lhs-m> <rhs-m> <name-m> (<action-spec-m-1> <body-m-1>) ... (<action-spec-m-n> <body-m-n>)))
; ==>
; grammar:
; (<lhs-1> <rhs-1> <name-1>)
; (<lhs-1> <rhs-1> <name-1> <current-highlight>)
; ...
; (<lhs-m> <rhs-m> <name-m>)
; (<lhs-m> <rhs-m> <name-m> <current-highlight>)
; commands:
; (%rule <lhs-1>)
; ...
@ -3188,7 +3266,8 @@
(actions (assert-type (cddddr production) (list (tuple t t)))))
(unless (actions-match action-declarations actions)
(error "Action name mismatch: ~S vs. ~S" action-declarations actions))
(push (list lhs rhs name) (preprocessor-state-grammar-source-reverse preprocessor-state))
(push (list lhs rhs name (preprocessor-state-highlight preprocessor-state))
(preprocessor-state-grammar-source-reverse preprocessor-state))
(push (list '%rule lhs) commands-reverse)))
(dotimes (i (length action-declarations))
(let ((action-declaration (nth i action-declarations)))

19
js/semantics/CalculusMarkup.lisp
View File

@ -113,11 +113,16 @@
(error "Bad command: ~S" command)))))
; Emit markup paragraphs for a list of commands.
(defun depict-commands (markup-stream world depict-env commands)
(dolist (command commands)
(depict-command markup-stream world depict-env command)))
; Emit markup paragraphs for the world's commands.
(defun depict-world-commands (markup-stream world &key (visible-semantics t))
(let ((depict-env (make-depict-env visible-semantics)))
(dolist (command (world-commands-source world))
(depict-command markup-stream world depict-env command))
(depict-commands markup-stream world depict-env (world-commands-source world))
(depict-clear-grammar markup-stream world depict-env)))
@ -861,6 +866,14 @@
,@body)))
; (%highlight <highlight> <command> ... <command>)
; Depict the commands highlighted with the <highlight> block style.
(defun depict-%highlight (markup-stream world depict-env highlight &rest commands)
(when commands
(depict-block-style (markup-stream highlight t)
(depict-commands markup-stream world depict-env commands))))
; (%section "section-name")
(defun depict-%section (markup-stream world depict-env section-name)
(declare (ignore world))
@ -936,7 +949,7 @@
(when (some #'seen-nonterminal? rule-lhs-nonterminals)
(warn "General rule for ~S listed before specific ones; use %rule to disambiguate" general-nonterminal))
(when visible
(depict-general-rule markup-stream general-rule))
(depict-general-rule markup-stream general-rule (grammar-highlights grammar)))
(dolist (nonterminal rule-lhs-nonterminals)
(setf (gethash nonterminal seen-nonterminals) t))))))))))
;******** May still have a problem when a specific rule precedes a general one.

124
js/semantics/Grammar.lisp
View File

@ -218,7 +218,8 @@
(lhs nil :type general-nonterminal :read-only t) ;The general-nonterminal on the left-hand side of this general-production
(rhs nil :type list :read-only t) ;List of general grammar symbols to which that general-nonterminal expands
(constraints nil :type list :read-only t) ;List of constraints applying to rhs, sorted by increasing pos values
(name nil :read-only t)) ;This general-production's name that will be used to name the parse tree node
(name nil :read-only t) ;This general-production's name that will be used to name the parse tree node
(highlight nil :read-only t)) ;This general-production's markup style keyword or nil if default
; If general-production is a generic-production, return its list of productions;
@ -340,7 +341,7 @@
;;; The evaluator is a lisp form that evaluates to a function f that takes one argument --
;;; the old state of the parser's value stack -- and returns the new state of that stack.
(defstruct (production (:include general-production (lhs nil :type nonterminal :read-only t))
(:constructor make-production (lhs rhs constraints name rhs-length number))
(:constructor make-production (lhs rhs constraints name highlight rhs-length number))
(:copier nil) (:predicate production?))
(rhs-length nil :type integer :read-only t) ;Number of grammar symbols in the rhs
(number nil :type integer :read-only t) ;This production's serial number
@ -385,7 +386,7 @@
;;; A generic production is not a production and does not have a number or actions.
(defstruct (generic-production (:include general-production (lhs nil :type generic-nonterminal :read-only t))
(:constructor make-generic-production (lhs rhs constraints name productions))
(:constructor make-generic-production (lhs rhs constraints name highlight productions))
(:copier nil)
(:predicate generic-production?))
(productions nil :type list :read-only t)) ;List of instantiations of this generic production
@ -404,6 +405,7 @@
(generic-production-rhs generic-production))
(general-production-constraints generic-production)
(generic-production-name generic-production)
(generic-production-highlight generic-production)
(remove-if #'(lambda (production)
(not (general-nonterminal-is-instance? grammar-parametrization new-lhs (production-lhs production))))
productions))
@ -426,24 +428,62 @@
(general-production-lhs (first (general-rule-productions general-rule))))
; Return the given highlight. If it is nil, return nil and ensure that no other
; highlight (from the list given by highlights) is currently in effect in the markup-stream.
(defun check-highlight (highlight highlights markup-stream)
(if highlight
(assert-true (member highlight highlights))
(dolist (h highlights)
(ensure-no-enclosing-style markup-stream h)))
highlight)
; Return the list of general-productions, in order, gathered into runs of consecutive productions with the same highlight value.
; The result is a list of runs:
; (<highlight> <p> ... <p>),
; where each <p> is:
; (<general-production> <first> <last>),
; where <first> is true if this is the first production and <last> is true if this is the last production.
(defun gather-productions-by-highlights (general-productions)
(when general-productions
(let* ((first-production (first general-productions))
(prior-runs-reverse nil)
(current-highlight (general-production-highlight first-production))
(current-run-productions-reverse (list (list first-production t nil))))
(dolist (general-production (rest general-productions))
(let ((highlight (general-production-highlight general-production))
(p (list general-production nil nil)))
(if (eq highlight current-highlight)
(push p current-run-productions-reverse)
(progn
(push (cons current-highlight (nreverse current-run-productions-reverse)) prior-runs-reverse)
(setq current-highlight highlight)
(setq current-run-productions-reverse (list p))))))
(setf (third (first current-run-productions-reverse)) t)
(nreconc prior-runs-reverse (list (cons current-highlight (nreverse current-run-productions-reverse)))))))
; Emit markup paragraphs for the grammar general rule.
; If the rule is short enough (only one production), emit the rule on one line.
(defun depict-general-rule (markup-stream general-rule)
(depict-block-style (markup-stream ':grammar-rule)
(let ((general-productions (general-rule-productions general-rule)))
(assert-true general-productions)
(if (cdr general-productions)
(labels
((emit-general-productions (general-productions first)
(let ((general-production (first general-productions))
(rest (rest general-productions)))
(depict-general-production-rhs markup-stream general-production first (endp rest))
(when rest
(emit-general-productions rest nil)))))
(depict-general-production-lhs markup-stream (general-rule-lhs general-rule))
(emit-general-productions general-productions t))
(depict-paragraph (markup-stream ':grammar-lhs-last)
(depict-general-production markup-stream (first general-productions) :definition))))))
; highlights is a list of keywords that may be used to highlight specific rules or productions. It should
; be the same as the list of highlights passed to make-grammar.
(defun depict-general-rule (markup-stream general-rule highlights)
(let ((general-productions (general-rule-productions general-rule)))
(assert-true general-productions)
(let* ((production-runs (gather-productions-by-highlights general-productions))
(rule-highlight (and (endp (rest production-runs))
(check-highlight (first (first production-runs)) highlights markup-stream))))
(depict-block-style (markup-stream rule-highlight t)
(depict-block-style (markup-stream ':grammar-rule)
(if (rest general-productions)
(progn
(depict-general-production-lhs markup-stream (general-rule-lhs general-rule))
(dolist (production-run production-runs)
(depict-block-style (markup-stream (check-highlight (first production-run) highlights markup-stream) t)
(dolist (p (rest production-run))
(apply #'depict-general-production-rhs markup-stream p)))))
(depict-paragraph (markup-stream ':grammar-lhs-last)
(depict-general-production markup-stream (first general-productions) :definition))))))))
;;; ------------------------------------------------------------------------------------------------------
@ -1046,6 +1086,7 @@
(max-production-length nil :type integer :read-only t) ;Maximum number of grammar symbols in the rhs of a production
(general-productions nil :type hash-table :read-only t);Hash table of production-name -> general-production
(n-productions nil :type integer :read-only t) ;Number of productions in the grammar
(highlights nil :type list :read-only t) ;List of style keywords for highlighting selected productions
;The following fields are used for the parser.
(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)
@ -1174,15 +1215,18 @@
; Intern attributed or generic nonterminals in the production's lhs and rhs. Replace
; (:- <terminal> ... <terminal>) or (:-- (<grammar-symbol> ... <grammar-symbol>) <terminal> ... <terminal>)
; sublists in the rhs with lookahead-constraints and put these, in order, after the third element of
; sublists in the rhs with lookahead-constraints and put these, in order, after the fourth element of
; the returned list. Also replace variant constraint symbols with variant-constraints.
; The variant-constraint-names parameter should be a list of possible variant constraint symbols.
; Return the resulting production source.
(defun intern-production-source (grammar-parametrization variant-constraint-names production-source)
(assert-type production-source (tuple (or user-nonterminal cons) (list (or user-grammar-symbol cons)) identifier))
(defun intern-production-source (grammar-parametrization variant-constraint-names highlights production-source)
(assert-type production-source (tuple (or user-nonterminal cons) (list (or user-grammar-symbol cons)) identifier t))
(let ((production-lhs-source (first production-source))
(production-rhs-source (second production-source))
(production-name (third production-source)))
(production-name (third production-source))
(production-highlight (fourth production-source)))
(unless (or (null production-highlight) (member production-highlight highlights :test #'eq))
(error "Bad highlight in rule: ~S; allowed highlights are ~S" production-source highlights))
(if (or (consp production-lhs-source) (some #'consp production-rhs-source) (intersection variant-constraint-names production-rhs-source))
(multiple-value-bind (lhs-nonterminal lhs-arguments) (grammar-parametrization-intern grammar-parametrization production-lhs-source)
(let ((rhs nil)
@ -1205,7 +1249,7 @@
(t
(push (grammar-parametrization-intern grammar-parametrization component-source lhs-arguments) rhs)
(incf pos))))
(list* lhs-nonterminal (nreverse rhs) production-name (nreverse constraints))))
(list* lhs-nonterminal (nreverse rhs) production-name production-highlight (nreverse constraints))))
production-source)))
@ -1213,7 +1257,8 @@
; A grammar-source is a list of productions; each production is a list of:
; a nonterminal A (the lhs);
; a list of grammar symbols forming A's expansion (the rhs);
; a production name.
; a production name;
; a highlight keyword or nil.
; Nonterminals in the lhs and rhs can be parametrized; in this case such a nonterminal
; is represented by a list whose first element is the name and the remaining elements are
; the arguments or attributes. Any nonterminal argument in the rhs must also be an argument
@ -1241,11 +1286,15 @@
; excluded-nonterminals is a list of nonterminals not used in the grammar. Productions,
; including productions expanded from generic productions, that have one of these nonterminals
; on the lhs are ignored.
(defun make-grammar (grammar-parametrization start-symbol grammar-source &key variant-constraint-names variant-generator excluded-nonterminals)
;
; highlights is a list of keywords that may be used to highlight specific rules or productions. Each production that includes
; a highlight as its fourth element will be rendered using the markup style specified by highlight.
(defun make-grammar (grammar-parametrization start-symbol grammar-source &key variant-constraint-names variant-generator excluded-nonterminals highlights)
(assert-type highlights (list keyword))
(let ((variant-constraint-forbid-lists (mapcar #'list variant-constraint-names))
(interned-grammar-source
(mapcar #'(lambda (production-source)
(intern-production-source grammar-parametrization variant-constraint-names production-source))
(intern-production-source grammar-parametrization variant-constraint-names highlights production-source))
grammar-source))
(rules (make-hash-table :test #'eq))
(terminals-hash (make-hash-table :test *grammar-symbol-=*))
@ -1264,12 +1313,12 @@
;Create the starting production: *start-nonterminal* ==> start-symbol
(setf (gethash *start-nonterminal* rules)
(list (make-production *start-nonterminal* (list start-symbol) nil nil 1 0)))
(list (make-production *start-nonterminal* (list start-symbol) nil nil nil 1 0)))
;Create the rest of the productions.
(flet
((create-production (lhs rhs constraints name)
(let ((production (make-production lhs rhs constraints name (length rhs) (incf production-number))))
((create-production (lhs rhs constraints name highlight)
(let ((production (make-production lhs rhs constraints name highlight (length rhs) (incf production-number))))
(push production (gethash lhs rules))
(dolist (rhs-terminal (production-terminals production))
(setf (gethash rhs-terminal terminals-hash) t))
@ -1283,7 +1332,8 @@
(let* ((production-lhs (first production-source))
(production-rhs (second production-source))
(production-name (third production-source))
(production-constraints (cdddr production-source))
(production-highlight (fourth production-source))
(production-constraints (cddddr production-source))
(lhs-arguments (general-grammar-symbol-arguments production-lhs)))
(setq max-production-length (max max-production-length (length production-rhs)))
(when (gethash production-name general-productions)
@ -1301,16 +1351,17 @@
(instantiate-general-grammar-symbol bound-argument-alist general-grammar-symbol))
production-rhs)
production-constraints
production-name)
production-name
production-highlight)
productions))))
lhs-arguments)
(when productions
(setf (gethash production-name general-productions)
(make-generic-production production-lhs production-rhs production-constraints production-name (nreverse productions)))))
(make-generic-production production-lhs production-rhs production-constraints production-name production-highlight (nreverse productions)))))
(unless (nonterminal-excluded production-lhs)
(setf (gethash production-name general-productions)
(create-production production-lhs production-rhs production-constraints production-name)))))))
(create-production production-lhs production-rhs production-constraints production-name production-highlight)))))))
(when variant-generator
@ -1384,7 +1435,8 @@
:parameter-trees (make-hash-table :test *grammar-symbol-=*)
:max-production-length max-production-length
:general-productions general-productions
:n-productions production-number)))
:n-productions production-number
:highlights highlights)))
;Compute the terminalsets in the terminal-terminalsets.
(dotimes (n (length terminals))
@ -1527,7 +1579,7 @@
(depict-general-nonterminal markup-stream (gramar-user-start-symbol grammar) :reference))
(dolist (nonterminal (grammar-nonterminals-list grammar))
(unless (grammar-symbol-= nonterminal *start-nonterminal*)
(depict-general-rule markup-stream (grammar-rule grammar nonterminal)))))
(depict-general-rule markup-stream (grammar-rule grammar nonterminal) (grammar-highlights grammar)))))
; Return a list of nontrivial sets of states with the same kernels.

42
js/semantics/HTML.lisp
View File

@ -450,6 +450,8 @@
((:zeta 1) (:script "document.write(U_zeta)"))
;Block Styles
(:js2 (div (class "js2")))
(:es4 (div (class "es4")))
(:body-text p)
(:section-heading h2)
(:subsection-heading h3)
@ -509,9 +511,10 @@
;;; HTML STREAMS
(defstruct (html-stream (:include markup-stream)
(:constructor allocate-html-stream (env head tail level logical-position anchors))
(:constructor allocate-html-stream (env head tail level logical-position enclosing-styles anchors))
(:copier nil)
(:predicate html-stream?))
(enclosing-styles nil :type list :read-only t) ;A list of enclosing styles
(anchors nil :type list :read-only t)) ;A mutable cons cell for accumulating anchors at the beginning of a paragraph
; ;or nil if not inside a paragraph.
@ -522,9 +525,9 @@
; Make a new, empty, open html-stream with the given definitions for its markup-env.
(defun make-html-stream (markup-env level logical-position anchors)
(defun make-html-stream (markup-env level logical-position enclosing-styles anchors)
(let ((head (list nil)))
(allocate-html-stream markup-env head head level logical-position anchors)))
(allocate-html-stream markup-env head head level logical-position enclosing-styles anchors)))
; Make a new, empty, open, top-level html-stream with the given definitions
@ -533,7 +536,7 @@
(let ((head (list nil))
(markup-env (make-markup-env links)))
(markup-env-define-alist markup-env html-definitions)
(allocate-html-stream markup-env head head *markup-stream-top-level* nil nil)))
(allocate-html-stream markup-env head head *markup-stream-top-level* nil nil nil)))
; Return the approximate width of the html item; return t if it is a line break.
@ -585,14 +588,23 @@
(defmethod depict-block-style-f ((html-stream html-stream) block-style emitter)
(defmethod depict-block-style-f ((html-stream html-stream) block-style flatten emitter)
(assert-true (<= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
(assert-true (and block-style (symbolp block-style)))
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream) *markup-stream-paragraph-level* nil nil)))
(markup-stream-append1 inner-html-stream block-style)
(prog1
(funcall emitter inner-html-stream)
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
(assert-true (symbolp block-style))
(if (or (null block-style)
(and flatten (member block-style (html-stream-enclosing-styles html-stream))))
(funcall emitter html-stream)
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-paragraph-level*
nil
(cons block-style (html-stream-enclosing-styles html-stream))
nil)))
(markup-stream-append1 inner-html-stream block-style)
(prog1
(funcall emitter inner-html-stream)
(let ((inner-output (markup-stream-unexpanded-output inner-html-stream)))
(when (or (not flatten) (cdr inner-output))
(markup-stream-append1 html-stream inner-output)))))))
(defmethod depict-paragraph-f ((html-stream html-stream) paragraph-style emitter)
@ -602,6 +614,7 @@
(inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-content-level*
(make-logical-position)
(cons paragraph-style (html-stream-enclosing-styles html-stream))
anchors)))
(prog1
(funcall emitter inner-html-stream)
@ -616,6 +629,7 @@
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-content-level*
(markup-stream-logical-position html-stream)
(cons char-style (html-stream-enclosing-styles html-stream))
(html-stream-anchors html-stream))))
(markup-stream-append1 inner-html-stream char-style)
(prog1
@ -623,6 +637,11 @@
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
(defmethod ensure-no-enclosing-style ((html-stream html-stream) style)
(when (member style (html-stream-enclosing-styles html-stream))
(cerror "Ignore" "Style ~S should not be in effect" style)))
(defmethod depict-anchor ((html-stream html-stream) link-prefix link-name duplicate)
(assert-true (= (markup-stream-level html-stream) *markup-stream-content-level*))
(let* ((links (markup-env-links (html-stream-env html-stream)))
@ -639,6 +658,7 @@
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-content-level*
(markup-stream-logical-position html-stream)
(html-stream-enclosing-styles html-stream)
(html-stream-anchors html-stream))))
(markup-stream-append1 inner-html-stream (list 'a (list 'href href)))
(prog1

4
js/semantics/Lexer.lisp
View File

@ -383,7 +383,7 @@
; Return the charset of all characters that appear as terminals in grammar-source.
(defun grammar-singletons (grammar-source)
(assert-type grammar-source (list (tuple t (list t) identifier)))
(assert-type grammar-source (list (tuple t (list t) identifier t)))
(let ((singletons 0))
(labels
((scan-for-singletons (list)
@ -648,7 +648,7 @@
(char-charset partition-name)
(partition-charset (gethash partition-name (lexer-partitions lexer)))))
(production-name (intern (format nil "~A-~D" production-prefix (incf production-number)))))
(push (list nonterminal-source (list partition-name) production-name) productions)
(push (list nonterminal-source (list partition-name) production-name nil) productions)
(dolist (action (charclass-actions charclass))
(let* ((lexer-action (cdr action))
(body (if (characterp partition-name)

15
js/semantics/Markup.lisp
View File

@ -337,14 +337,16 @@
; markup-stream must be a variable that names a markup-stream that is currently
; accepting paragraphs. Execute body with markup-stream bound to a markup-stream
; to which the body can emit contents. The given block-style is applied to all
; to which the body can emit contents. If non-null, the given block-style is applied to all
; paragraphs emitted by body (in the HTML emitter only; RTF has no block styles).
; If flatten is true, do not emit the style if it is already in effect from a surrounding block
; or if its contents are empty.
; Return the result value of body.
(defmacro depict-block-style ((markup-stream block-style) &body body)
`(depict-block-style-f ,markup-stream ,block-style
(defmacro depict-block-style ((markup-stream block-style &optional flatten) &body body)
`(depict-block-style-f ,markup-stream ,block-style ,flatten
#'(lambda (,markup-stream) ,@body)))
(defgeneric depict-block-style-f (markup-stream block-style emitter))
(defgeneric depict-block-style-f (markup-stream block-style flatten emitter))
; markup-stream must be a variable that names a markup-stream that is currently
@ -371,6 +373,11 @@
(defgeneric depict-char-style-f (markup-stream char-style emitter))
; Ensure that the given style is not currently in effect in the markup-stream.
; RTF streams don't currently keep track of styles, so this function does nothing for RTF streams.
(defgeneric ensure-no-enclosing-style (markup-stream style))
; Depict an anchor. The concatenation of link-prefix and link-name must be a string
; suitable for an anchor name.
; If duplicate is true, allow duplicate calls for the same link-name, in which case only

8
js/semantics/RTF.lisp
View File

@ -757,8 +757,8 @@
(markup-env-expand (markup-stream-env rtf-stream) (markup-stream-unexpanded-output rtf-stream) nil))
(defmethod depict-block-style-f ((rtf-stream rtf-stream) block-style emitter)
(declare (ignore block-style))
(defmethod depict-block-style-f ((rtf-stream rtf-stream) block-style flatten emitter)
(declare (ignore block-style flatten))
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
(funcall emitter rtf-stream))
@ -790,6 +790,10 @@
(rtf-stream-append-or-inline-block rtf-stream (markup-stream-unexpanded-output inner-rtf-stream)))))
(defmethod ensure-no-enclosing-style ((rtf-stream rtf-stream) style)
(declare (ignore style)))
(defmethod depict-anchor ((rtf-stream rtf-stream) link-prefix link-name duplicate)
(declare (ignore link-prefix link-name duplicate))
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-content-level*)))

137
js2/semantics/Calculus.lisp
View File

@ -26,7 +26,7 @@
(defvar *trace-variables* nil)
#+mcl (dolist (indent-spec '((apply . 1) (funcall . 1) (production . 3) (rule . 2) (function . 1) (letexc . 1) (deftype . 1) (tuple . 1) (%text . 1)))
#+mcl (dolist (indent-spec '((? . 1) (apply . 1) (funcall . 1) (production . 3) (rule . 2) (function . 1) (letexc . 1) (deftype . 1) (tuple . 1) (%text . 1)))
(pushnew indent-spec ccl:*fred-special-indent-alist* :test #'equal))
@ -426,6 +426,7 @@
(defstruct (world (:constructor allocate-world)
(:copier nil)
(:predicate world?))
(conditionals nil :type list) ;Assoc list of (conditional . highlight), where highlight can be a style keyword, nil (no style), or 'delete
(package nil :type package) ;The package in which this world's identifiers are interned
(n-type-names 0 :type integer) ;Number of type names defined so far
(types-reverse nil :type (or null hash-table)) ;Hash table of (kind tags parameters) -> type; nil if invalid
@ -577,6 +578,25 @@
(and grammar-info (grammar-info-lexer grammar-info))))
; Return a list of highlights allowed in this world.
(defun world-highlights (world)
(let ((highlights nil))
(dolist (c (world-conditionals world))
(let ((highlight (cdr c)))
(unless (or (null highlight) (eq highlight 'delete))
(pushnew highlight highlights))))
(nreverse highlights)))
; Return the highlight to which the given conditional maps.
; Return 'delete if the conditional should be omitted.
(defun resolve-conditional (world conditional)
(let ((h (assoc conditional (world-conditionals world))))
(if h
(cdr h)
(error "Bad conditional ~S" conditional))))
;;; ------------------------------------------------------------------------------------------------------
;;; SYMBOLS
@ -2327,6 +2347,13 @@
;;; ------------------------------------------------------------------------------------------------------
;;; COMMANDS
; (%highlight <highlight> <command> ... <command>)
; Evaluate the given commands. <highlight> is a hint for printing.
(defun scan-%highlight (world grammar-info-var highlight &rest commands)
(declare (ignore highlight))
(scan-commands world grammar-info-var commands))
; (%... ...)
; Ignore any command that starts with a %. These commands are hints for printing.
(defun scan-% (world grammar-info-var &rest rest)
@ -2415,6 +2442,7 @@
(defparameter *default-specials*
'((:preprocess
(? preprocess-?)
(define preprocess-define)
(action preprocess-action)
(grammar preprocess-grammar)
@ -2431,6 +2459,7 @@
(set-of expand-set-of nil))
(:command
(%highlight scan-%highlight depict-%highlight) ;For internal use only; use ? instead.
(%section scan-% depict-%section)
(%subsection scan-% depict-%subsection)
(%text scan-% depict-%text)
@ -2636,8 +2665,15 @@
; Create a world with the given name and set up the built-in properties of its symbols.
(defun init-world (name)
; conditionals is an association list of (conditional . highlight), where conditional is a symbol
; and highlight is either:
; a style keyword: Use that style to highlight the contents of any (? conditional ...) commands
; nil: Include the contents of any (? conditional ...) commands without highlighting them
; delete: Don't include the contents of (? conditional ...) commands
(defun init-world (name conditionals)
(assert-type conditionals (list (cons symbol (or null keyword (eql delete)))))
(let ((world (make-world name)))
(setf (world-conditionals world) conditionals)
(dolist (specials-list *default-specials*)
(let ((property (car specials-list)))
(dolist (special-spec (cdr specials-list))
@ -2753,10 +2789,8 @@
;;; ------------------------------------------------------------------------------------------------------
;;; EVALUATION
; Scan a command. Create types and variables in the world
; but do not evaluate variables' types or values yet.
; grammar-info-var is a cons cell whose car is either nil
; or a grammar-info for the grammar currently being defined.
; Scan a command. Create types and variables in the world but do not evaluate variables' types or values yet.
; grammar-info-var is a cons cell whose car is either nil or a grammar-info for the grammar currently being defined.
(defun scan-command (world grammar-info-var command)
(handler-bind ((error #'(lambda (condition)
(declare (ignore condition))
@ -2769,6 +2803,12 @@
(error "Bad command")))))
; Scan a list of commands. See scan-command above.
(defun scan-commands (world grammar-info-var commands)
(dolist (command commands)
(scan-command world grammar-info-var command)))
; Compute the primitives' types from their type-exprs.
(defun define-primitives (world)
(each-world-external-symbol-with-property
@ -2864,8 +2904,7 @@
(assert-true (null (world-commands-source world)))
(setf (world-commands-source world) commands)
(let ((grammar-info-var (list nil)))
(dolist (command commands)
(scan-command world grammar-info-var command)))
(scan-commands world grammar-info-var commands))
(unite-types world)
(setf (world-bottom-type world) (make-type world :bottom nil nil))
(setf (world-void-type world) (make-type world :void nil nil))
@ -2884,7 +2923,9 @@
;;; ------------------------------------------------------------------------------------------------------
;;; PREPROCESSING
(defstruct preprocessor-state
(defstruct (preprocessor-state (:constructor make-preprocessor-state (world)))
(world nil :type world :read-only t) ;The world into which preprocessed symbols are interned
(highlight nil :type symbol) ;The current highlight style or nil if none
(kind nil :type (member nil :grammar :lexer)) ;The kind of grammar being accumulated or nil if none
(kind2 nil :type (member nil :lalr-1 :lr-1 :canonical-lr-1)) ;The kind of parser
(name nil :type symbol) ;Name of the grammar being accumulated or nil if none
@ -2914,7 +2955,8 @@
(start-symbol (preprocessor-state-start-symbol preprocessor-state))
(grammar-source (nreverse (preprocessor-state-grammar-source-reverse preprocessor-state)))
(excluded-nonterminals-source (preprocessor-state-excluded-nonterminals-source preprocessor-state))
(grammar-options (preprocessor-state-grammar-options preprocessor-state)))
(grammar-options (preprocessor-state-grammar-options preprocessor-state))
(highlights (world-highlights (preprocessor-state-world preprocessor-state))))
(multiple-value-bind (grammar lexer extra-commands)
(ecase kind
(:grammar
@ -2924,6 +2966,7 @@
start-symbol
grammar-source
:excluded-nonterminals excluded-nonterminals-source
:highlights highlights
grammar-options)
nil
nil))
@ -2937,6 +2980,7 @@
start-symbol
grammar-source
:excluded-nonterminals excluded-nonterminals-source
:highlights highlights
grammar-options)
(values (lexer-grammar lexer) lexer extra-commands))))
(let ((grammar-info (make-grammar-info (preprocessor-state-name preprocessor-state) grammar lexer)))
@ -2954,19 +2998,17 @@
(append extra-commands (list '(clear-grammar)))))))))
; Helper function for preprocess-source.
; source is a list of preprocessor directives and commands. Preprocess these commands
; and return the following results:
; a list of preprocessed commands;
; a list of grammar-infos extracted from preprocessor directives.
(defun preprocess-source (world source)
(let ((preprocessor-state (make-preprocessor-state)))
(labels
; using the given preprocessor-state and return the resulting list of commands.
(defun preprocess-list (preprocessor-state source)
(let ((world (preprocessor-state-world preprocessor-state)))
(flet
((preprocess-one (form)
(when (consp form)
(let ((first (car form)))
(when (identifier? first)
(let* ((symbol (world-intern world first))
(action (symbol-preprocessor-function symbol)))
(let ((action (symbol-preprocessor-function (world-intern world first))))
(when action
(handler-bind ((error #'(lambda (condition)
(declare (ignore condition))
@ -2974,19 +3016,33 @@
(multiple-value-bind (preprocessed-form re-preprocess) (apply action preprocessor-state form)
(return-from preprocess-one
(if re-preprocess
(mapcan #'preprocess-one preprocessed-form)
(preprocess-list preprocessor-state preprocessed-form)
preprocessed-form)))))))))
(list form)))
(let* ((commands (mapcan #'preprocess-one source))
(commands (nconc commands (preprocessor-state-finish-grammar preprocessor-state))))
(values commands (nreverse (preprocessor-state-grammar-infos-reverse preprocessor-state)))))))
(mapcan #'preprocess-one source))))
; source is a list of preprocessor directives and commands. Preprocess these commands
; and return the following results:
; a list of preprocessed commands;
; a list of grammar-infos extracted from preprocessor directives.
(defun preprocess-source (world source)
(let* ((preprocessor-state (make-preprocessor-state world))
(commands (preprocess-list preprocessor-state source))
(commands (nconc commands (preprocessor-state-finish-grammar preprocessor-state))))
(values commands (nreverse (preprocessor-state-grammar-infos-reverse preprocessor-state)))))
; Create a new world with the given name and preprocess and evaluate the given
; source commands in it.
(defun generate-world (name source)
(let ((world (init-world name)))
; conditionals is an association list of (conditional . highlight), where conditional is a symbol
; and highlight is either:
; a style keyword: Use that style to highlight the contents of any (? conditional ...) commands
; nil: Include the contents of any (? conditional ...) commands without highlighting them
; delete: Don't include the contents of (? conditional ...) commands
(defun generate-world (name source &optional conditionals)
(let ((world (init-world name conditionals)))
(multiple-value-bind (commands grammar-infos) (preprocess-source world source)
(dolist (grammar-info grammar-infos)
(clear-actions (grammar-info-grammar grammar-info)))
@ -2999,6 +3055,27 @@
;;; PREPROCESSOR ACTIONS
; (? <conditional> <command> ... <command>)
; ==>
; (%highlight <highlight> <command> ... <command>)
; or
; <empty>
(defun preprocess-? (preprocessor-state command conditional &rest commands)
(declare (ignore command))
(let ((highlight (resolve-conditional (preprocessor-state-world preprocessor-state) conditional))
(saved-highlight (preprocessor-state-highlight preprocessor-state)))
(cond
((eq highlight 'delete) (values nil nil))
((eq highlight saved-highlight) (values commands t))
(t (values
(unwind-protect
(progn
(setf (preprocessor-state-highlight preprocessor-state) highlight)
(list (list* '%highlight highlight (preprocess-list preprocessor-state commands))))
(setf (preprocessor-state-highlight preprocessor-state) saved-highlight))
nil)))))
; (define <name> <type> <value>)
; ==>
; (define <name> <type> <value> nil)
@ -3123,7 +3200,7 @@
; (production <lhs> <rhs> <name> (<action-spec-1> <body-1>) ... (<action-spec-n> <body-n>))
; ==>
; grammar:
; (<lhs> <rhs> <name>)
; (<lhs> <rhs> <name> <current-highlight>)
; commands:
; (%rule <lhs>)
; (action <action-spec-1> <name> <body-1>)
@ -3133,7 +3210,8 @@
(declare (ignore command))
(assert-type actions (list (tuple t t)))
(preprocess-ensure-grammar preprocessor-state)
(push (list lhs rhs name) (preprocessor-state-grammar-source-reverse preprocessor-state))
(push (list lhs rhs name (preprocessor-state-highlight preprocessor-state))
(preprocessor-state-grammar-source-reverse preprocessor-state))
(values
(cons (list '%rule lhs)
(mapcar #'(lambda (action)
@ -3149,9 +3227,9 @@
; (production <lhs-m> <rhs-m> <name-m> (<action-spec-m-1> <body-m-1>) ... (<action-spec-m-n> <body-m-n>)))
; ==>
; grammar:
; (<lhs-1> <rhs-1> <name-1>)
; (<lhs-1> <rhs-1> <name-1> <current-highlight>)
; ...
; (<lhs-m> <rhs-m> <name-m>)
; (<lhs-m> <rhs-m> <name-m> <current-highlight>)
; commands:
; (%rule <lhs-1>)
; ...
@ -3188,7 +3266,8 @@
(actions (assert-type (cddddr production) (list (tuple t t)))))
(unless (actions-match action-declarations actions)
(error "Action name mismatch: ~S vs. ~S" action-declarations actions))
(push (list lhs rhs name) (preprocessor-state-grammar-source-reverse preprocessor-state))
(push (list lhs rhs name (preprocessor-state-highlight preprocessor-state))
(preprocessor-state-grammar-source-reverse preprocessor-state))
(push (list '%rule lhs) commands-reverse)))
(dotimes (i (length action-declarations))
(let ((action-declaration (nth i action-declarations)))

19
js2/semantics/CalculusMarkup.lisp
View File

@ -113,11 +113,16 @@
(error "Bad command: ~S" command)))))
; Emit markup paragraphs for a list of commands.
(defun depict-commands (markup-stream world depict-env commands)
(dolist (command commands)
(depict-command markup-stream world depict-env command)))
; Emit markup paragraphs for the world's commands.
(defun depict-world-commands (markup-stream world &key (visible-semantics t))
(let ((depict-env (make-depict-env visible-semantics)))
(dolist (command (world-commands-source world))
(depict-command markup-stream world depict-env command))
(depict-commands markup-stream world depict-env (world-commands-source world))
(depict-clear-grammar markup-stream world depict-env)))
@ -861,6 +866,14 @@
,@body)))
; (%highlight <highlight> <command> ... <command>)
; Depict the commands highlighted with the <highlight> block style.
(defun depict-%highlight (markup-stream world depict-env highlight &rest commands)
(when commands
(depict-block-style (markup-stream highlight t)
(depict-commands markup-stream world depict-env commands))))
; (%section "section-name")
(defun depict-%section (markup-stream world depict-env section-name)
(declare (ignore world))
@ -936,7 +949,7 @@
(when (some #'seen-nonterminal? rule-lhs-nonterminals)
(warn "General rule for ~S listed before specific ones; use %rule to disambiguate" general-nonterminal))
(when visible
(depict-general-rule markup-stream general-rule))
(depict-general-rule markup-stream general-rule (grammar-highlights grammar)))
(dolist (nonterminal rule-lhs-nonterminals)
(setf (gethash nonterminal seen-nonterminals) t))))))))))
;******** May still have a problem when a specific rule precedes a general one.

124
js2/semantics/Grammar.lisp
View File

@ -218,7 +218,8 @@
(lhs nil :type general-nonterminal :read-only t) ;The general-nonterminal on the left-hand side of this general-production
(rhs nil :type list :read-only t) ;List of general grammar symbols to which that general-nonterminal expands
(constraints nil :type list :read-only t) ;List of constraints applying to rhs, sorted by increasing pos values
(name nil :read-only t)) ;This general-production's name that will be used to name the parse tree node
(name nil :read-only t) ;This general-production's name that will be used to name the parse tree node
(highlight nil :read-only t)) ;This general-production's markup style keyword or nil if default
; If general-production is a generic-production, return its list of productions;
@ -340,7 +341,7 @@
;;; The evaluator is a lisp form that evaluates to a function f that takes one argument --
;;; the old state of the parser's value stack -- and returns the new state of that stack.
(defstruct (production (:include general-production (lhs nil :type nonterminal :read-only t))
(:constructor make-production (lhs rhs constraints name rhs-length number))
(:constructor make-production (lhs rhs constraints name highlight rhs-length number))
(:copier nil) (:predicate production?))
(rhs-length nil :type integer :read-only t) ;Number of grammar symbols in the rhs
(number nil :type integer :read-only t) ;This production's serial number
@ -385,7 +386,7 @@
;;; A generic production is not a production and does not have a number or actions.
(defstruct (generic-production (:include general-production (lhs nil :type generic-nonterminal :read-only t))
(:constructor make-generic-production (lhs rhs constraints name productions))
(:constructor make-generic-production (lhs rhs constraints name highlight productions))
(:copier nil)
(:predicate generic-production?))
(productions nil :type list :read-only t)) ;List of instantiations of this generic production
@ -404,6 +405,7 @@
(generic-production-rhs generic-production))
(general-production-constraints generic-production)
(generic-production-name generic-production)
(generic-production-highlight generic-production)
(remove-if #'(lambda (production)
(not (general-nonterminal-is-instance? grammar-parametrization new-lhs (production-lhs production))))
productions))
@ -426,24 +428,62 @@
(general-production-lhs (first (general-rule-productions general-rule))))
; Return the given highlight. If it is nil, return nil and ensure that no other
; highlight (from the list given by highlights) is currently in effect in the markup-stream.
(defun check-highlight (highlight highlights markup-stream)
(if highlight
(assert-true (member highlight highlights))
(dolist (h highlights)
(ensure-no-enclosing-style markup-stream h)))
highlight)
; Return the list of general-productions, in order, gathered into runs of consecutive productions with the same highlight value.
; The result is a list of runs:
; (<highlight> <p> ... <p>),
; where each <p> is:
; (<general-production> <first> <last>),
; where <first> is true if this is the first production and <last> is true if this is the last production.
(defun gather-productions-by-highlights (general-productions)
(when general-productions
(let* ((first-production (first general-productions))
(prior-runs-reverse nil)
(current-highlight (general-production-highlight first-production))
(current-run-productions-reverse (list (list first-production t nil))))
(dolist (general-production (rest general-productions))
(let ((highlight (general-production-highlight general-production))
(p (list general-production nil nil)))
(if (eq highlight current-highlight)
(push p current-run-productions-reverse)
(progn
(push (cons current-highlight (nreverse current-run-productions-reverse)) prior-runs-reverse)
(setq current-highlight highlight)
(setq current-run-productions-reverse (list p))))))
(setf (third (first current-run-productions-reverse)) t)
(nreconc prior-runs-reverse (list (cons current-highlight (nreverse current-run-productions-reverse)))))))
; Emit markup paragraphs for the grammar general rule.
; If the rule is short enough (only one production), emit the rule on one line.
(defun depict-general-rule (markup-stream general-rule)
(depict-block-style (markup-stream ':grammar-rule)
(let ((general-productions (general-rule-productions general-rule)))
(assert-true general-productions)
(if (cdr general-productions)
(labels
((emit-general-productions (general-productions first)
(let ((general-production (first general-productions))
(rest (rest general-productions)))
(depict-general-production-rhs markup-stream general-production first (endp rest))
(when rest
(emit-general-productions rest nil)))))
(depict-general-production-lhs markup-stream (general-rule-lhs general-rule))
(emit-general-productions general-productions t))
(depict-paragraph (markup-stream ':grammar-lhs-last)
(depict-general-production markup-stream (first general-productions) :definition))))))
; highlights is a list of keywords that may be used to highlight specific rules or productions. It should
; be the same as the list of highlights passed to make-grammar.
(defun depict-general-rule (markup-stream general-rule highlights)
(let ((general-productions (general-rule-productions general-rule)))
(assert-true general-productions)
(let* ((production-runs (gather-productions-by-highlights general-productions))
(rule-highlight (and (endp (rest production-runs))
(check-highlight (first (first production-runs)) highlights markup-stream))))
(depict-block-style (markup-stream rule-highlight t)
(depict-block-style (markup-stream ':grammar-rule)
(if (rest general-productions)
(progn
(depict-general-production-lhs markup-stream (general-rule-lhs general-rule))
(dolist (production-run production-runs)
(depict-block-style (markup-stream (check-highlight (first production-run) highlights markup-stream) t)
(dolist (p (rest production-run))
(apply #'depict-general-production-rhs markup-stream p)))))
(depict-paragraph (markup-stream ':grammar-lhs-last)
(depict-general-production markup-stream (first general-productions) :definition))))))))
;;; ------------------------------------------------------------------------------------------------------
@ -1046,6 +1086,7 @@
(max-production-length nil :type integer :read-only t) ;Maximum number of grammar symbols in the rhs of a production
(general-productions nil :type hash-table :read-only t);Hash table of production-name -> general-production
(n-productions nil :type integer :read-only t) ;Number of productions in the grammar
(highlights nil :type list :read-only t) ;List of style keywords for highlighting selected productions
;The following fields are used for the parser.
(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)
@ -1174,15 +1215,18 @@
; Intern attributed or generic nonterminals in the production's lhs and rhs. Replace
; (:- <terminal> ... <terminal>) or (:-- (<grammar-symbol> ... <grammar-symbol>) <terminal> ... <terminal>)
; sublists in the rhs with lookahead-constraints and put these, in order, after the third element of
; sublists in the rhs with lookahead-constraints and put these, in order, after the fourth element of
; the returned list. Also replace variant constraint symbols with variant-constraints.
; The variant-constraint-names parameter should be a list of possible variant constraint symbols.
; Return the resulting production source.
(defun intern-production-source (grammar-parametrization variant-constraint-names production-source)
(assert-type production-source (tuple (or user-nonterminal cons) (list (or user-grammar-symbol cons)) identifier))
(defun intern-production-source (grammar-parametrization variant-constraint-names highlights production-source)
(assert-type production-source (tuple (or user-nonterminal cons) (list (or user-grammar-symbol cons)) identifier t))
(let ((production-lhs-source (first production-source))
(production-rhs-source (second production-source))
(production-name (third production-source)))
(production-name (third production-source))
(production-highlight (fourth production-source)))
(unless (or (null production-highlight) (member production-highlight highlights :test #'eq))
(error "Bad highlight in rule: ~S; allowed highlights are ~S" production-source highlights))
(if (or (consp production-lhs-source) (some #'consp production-rhs-source) (intersection variant-constraint-names production-rhs-source))
(multiple-value-bind (lhs-nonterminal lhs-arguments) (grammar-parametrization-intern grammar-parametrization production-lhs-source)
(let ((rhs nil)
@ -1205,7 +1249,7 @@
(t
(push (grammar-parametrization-intern grammar-parametrization component-source lhs-arguments) rhs)
(incf pos))))
(list* lhs-nonterminal (nreverse rhs) production-name (nreverse constraints))))
(list* lhs-nonterminal (nreverse rhs) production-name production-highlight (nreverse constraints))))
production-source)))
@ -1213,7 +1257,8 @@
; A grammar-source is a list of productions; each production is a list of:
; a nonterminal A (the lhs);
; a list of grammar symbols forming A's expansion (the rhs);
; a production name.
; a production name;
; a highlight keyword or nil.
; Nonterminals in the lhs and rhs can be parametrized; in this case such a nonterminal
; is represented by a list whose first element is the name and the remaining elements are
; the arguments or attributes. Any nonterminal argument in the rhs must also be an argument
@ -1241,11 +1286,15 @@
; excluded-nonterminals is a list of nonterminals not used in the grammar. Productions,
; including productions expanded from generic productions, that have one of these nonterminals
; on the lhs are ignored.
(defun make-grammar (grammar-parametrization start-symbol grammar-source &key variant-constraint-names variant-generator excluded-nonterminals)
;
; highlights is a list of keywords that may be used to highlight specific rules or productions. Each production that includes
; a highlight as its fourth element will be rendered using the markup style specified by highlight.
(defun make-grammar (grammar-parametrization start-symbol grammar-source &key variant-constraint-names variant-generator excluded-nonterminals highlights)
(assert-type highlights (list keyword))
(let ((variant-constraint-forbid-lists (mapcar #'list variant-constraint-names))
(interned-grammar-source
(mapcar #'(lambda (production-source)
(intern-production-source grammar-parametrization variant-constraint-names production-source))
(intern-production-source grammar-parametrization variant-constraint-names highlights production-source))
grammar-source))
(rules (make-hash-table :test #'eq))
(terminals-hash (make-hash-table :test *grammar-symbol-=*))
@ -1264,12 +1313,12 @@
;Create the starting production: *start-nonterminal* ==> start-symbol
(setf (gethash *start-nonterminal* rules)
(list (make-production *start-nonterminal* (list start-symbol) nil nil 1 0)))
(list (make-production *start-nonterminal* (list start-symbol) nil nil nil 1 0)))
;Create the rest of the productions.
(flet
((create-production (lhs rhs constraints name)
(let ((production (make-production lhs rhs constraints name (length rhs) (incf production-number))))
((create-production (lhs rhs constraints name highlight)
(let ((production (make-production lhs rhs constraints name highlight (length rhs) (incf production-number))))
(push production (gethash lhs rules))
(dolist (rhs-terminal (production-terminals production))
(setf (gethash rhs-terminal terminals-hash) t))
@ -1283,7 +1332,8 @@
(let* ((production-lhs (first production-source))
(production-rhs (second production-source))
(production-name (third production-source))
(production-constraints (cdddr production-source))
(production-highlight (fourth production-source))
(production-constraints (cddddr production-source))
(lhs-arguments (general-grammar-symbol-arguments production-lhs)))
(setq max-production-length (max max-production-length (length production-rhs)))
(when (gethash production-name general-productions)
@ -1301,16 +1351,17 @@
(instantiate-general-grammar-symbol bound-argument-alist general-grammar-symbol))
production-rhs)
production-constraints
production-name)
production-name
production-highlight)
productions))))
lhs-arguments)
(when productions
(setf (gethash production-name general-productions)
(make-generic-production production-lhs production-rhs production-constraints production-name (nreverse productions)))))
(make-generic-production production-lhs production-rhs production-constraints production-name production-highlight (nreverse productions)))))
(unless (nonterminal-excluded production-lhs)
(setf (gethash production-name general-productions)
(create-production production-lhs production-rhs production-constraints production-name)))))))
(create-production production-lhs production-rhs production-constraints production-name production-highlight)))))))
(when variant-generator
@ -1384,7 +1435,8 @@
:parameter-trees (make-hash-table :test *grammar-symbol-=*)
:max-production-length max-production-length
:general-productions general-productions
:n-productions production-number)))
:n-productions production-number
:highlights highlights)))
;Compute the terminalsets in the terminal-terminalsets.
(dotimes (n (length terminals))
@ -1527,7 +1579,7 @@
(depict-general-nonterminal markup-stream (gramar-user-start-symbol grammar) :reference))
(dolist (nonterminal (grammar-nonterminals-list grammar))
(unless (grammar-symbol-= nonterminal *start-nonterminal*)
(depict-general-rule markup-stream (grammar-rule grammar nonterminal)))))
(depict-general-rule markup-stream (grammar-rule grammar nonterminal) (grammar-highlights grammar)))))
; Return a list of nontrivial sets of states with the same kernels.

42
js2/semantics/HTML.lisp
View File

@ -450,6 +450,8 @@
((:zeta 1) (:script "document.write(U_zeta)"))
;Block Styles
(:js2 (div (class "js2")))
(:es4 (div (class "es4")))
(:body-text p)
(:section-heading h2)
(:subsection-heading h3)
@ -509,9 +511,10 @@
;;; HTML STREAMS
(defstruct (html-stream (:include markup-stream)
(:constructor allocate-html-stream (env head tail level logical-position anchors))
(:constructor allocate-html-stream (env head tail level logical-position enclosing-styles anchors))
(:copier nil)
(:predicate html-stream?))
(enclosing-styles nil :type list :read-only t) ;A list of enclosing styles
(anchors nil :type list :read-only t)) ;A mutable cons cell for accumulating anchors at the beginning of a paragraph
; ;or nil if not inside a paragraph.
@ -522,9 +525,9 @@
; Make a new, empty, open html-stream with the given definitions for its markup-env.
(defun make-html-stream (markup-env level logical-position anchors)
(defun make-html-stream (markup-env level logical-position enclosing-styles anchors)
(let ((head (list nil)))
(allocate-html-stream markup-env head head level logical-position anchors)))
(allocate-html-stream markup-env head head level logical-position enclosing-styles anchors)))
; Make a new, empty, open, top-level html-stream with the given definitions
@ -533,7 +536,7 @@
(let ((head (list nil))
(markup-env (make-markup-env links)))
(markup-env-define-alist markup-env html-definitions)
(allocate-html-stream markup-env head head *markup-stream-top-level* nil nil)))
(allocate-html-stream markup-env head head *markup-stream-top-level* nil nil nil)))
; Return the approximate width of the html item; return t if it is a line break.
@ -585,14 +588,23 @@
(defmethod depict-block-style-f ((html-stream html-stream) block-style emitter)
(defmethod depict-block-style-f ((html-stream html-stream) block-style flatten emitter)
(assert-true (<= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
(assert-true (and block-style (symbolp block-style)))
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream) *markup-stream-paragraph-level* nil nil)))
(markup-stream-append1 inner-html-stream block-style)
(prog1
(funcall emitter inner-html-stream)
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
(assert-true (symbolp block-style))
(if (or (null block-style)
(and flatten (member block-style (html-stream-enclosing-styles html-stream))))
(funcall emitter html-stream)
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-paragraph-level*
nil
(cons block-style (html-stream-enclosing-styles html-stream))
nil)))
(markup-stream-append1 inner-html-stream block-style)
(prog1
(funcall emitter inner-html-stream)
(let ((inner-output (markup-stream-unexpanded-output inner-html-stream)))
(when (or (not flatten) (cdr inner-output))
(markup-stream-append1 html-stream inner-output)))))))
(defmethod depict-paragraph-f ((html-stream html-stream) paragraph-style emitter)
@ -602,6 +614,7 @@
(inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-content-level*
(make-logical-position)
(cons paragraph-style (html-stream-enclosing-styles html-stream))
anchors)))
(prog1
(funcall emitter inner-html-stream)
@ -616,6 +629,7 @@
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-content-level*
(markup-stream-logical-position html-stream)
(cons char-style (html-stream-enclosing-styles html-stream))
(html-stream-anchors html-stream))))
(markup-stream-append1 inner-html-stream char-style)
(prog1
@ -623,6 +637,11 @@
(markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
(defmethod ensure-no-enclosing-style ((html-stream html-stream) style)
(when (member style (html-stream-enclosing-styles html-stream))
(cerror "Ignore" "Style ~S should not be in effect" style)))
(defmethod depict-anchor ((html-stream html-stream) link-prefix link-name duplicate)
(assert-true (= (markup-stream-level html-stream) *markup-stream-content-level*))
(let* ((links (markup-env-links (html-stream-env html-stream)))
@ -639,6 +658,7 @@
(let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
*markup-stream-content-level*
(markup-stream-logical-position html-stream)
(html-stream-enclosing-styles html-stream)
(html-stream-anchors html-stream))))
(markup-stream-append1 inner-html-stream (list 'a (list 'href href)))
(prog1

4
js2/semantics/Lexer.lisp
View File

@ -383,7 +383,7 @@
; Return the charset of all characters that appear as terminals in grammar-source.
(defun grammar-singletons (grammar-source)
(assert-type grammar-source (list (tuple t (list t) identifier)))
(assert-type grammar-source (list (tuple t (list t) identifier t)))
(let ((singletons 0))
(labels
((scan-for-singletons (list)
@ -648,7 +648,7 @@
(char-charset partition-name)
(partition-charset (gethash partition-name (lexer-partitions lexer)))))
(production-name (intern (format nil "~A-~D" production-prefix (incf production-number)))))
(push (list nonterminal-source (list partition-name) production-name) productions)
(push (list nonterminal-source (list partition-name) production-name nil) productions)
(dolist (action (charclass-actions charclass))
(let* ((lexer-action (cdr action))
(body (if (characterp partition-name)

15
js2/semantics/Markup.lisp
View File

@ -337,14 +337,16 @@
; markup-stream must be a variable that names a markup-stream that is currently
; accepting paragraphs. Execute body with markup-stream bound to a markup-stream
; to which the body can emit contents. The given block-style is applied to all
; to which the body can emit contents. If non-null, the given block-style is applied to all
; paragraphs emitted by body (in the HTML emitter only; RTF has no block styles).
; If flatten is true, do not emit the style if it is already in effect from a surrounding block
; or if its contents are empty.
; Return the result value of body.
(defmacro depict-block-style ((markup-stream block-style) &body body)
`(depict-block-style-f ,markup-stream ,block-style
(defmacro depict-block-style ((markup-stream block-style &optional flatten) &body body)
`(depict-block-style-f ,markup-stream ,block-style ,flatten
#'(lambda (,markup-stream) ,@body)))
(defgeneric depict-block-style-f (markup-stream block-style emitter))
(defgeneric depict-block-style-f (markup-stream block-style flatten emitter))
; markup-stream must be a variable that names a markup-stream that is currently
@ -371,6 +373,11 @@
(defgeneric depict-char-style-f (markup-stream char-style emitter))
; Ensure that the given style is not currently in effect in the markup-stream.
; RTF streams don't currently keep track of styles, so this function does nothing for RTF streams.
(defgeneric ensure-no-enclosing-style (markup-stream style))
; Depict an anchor. The concatenation of link-prefix and link-name must be a string
; suitable for an anchor name.
; If duplicate is true, allow duplicate calls for the same link-name, in which case only

8
js2/semantics/RTF.lisp
View File

@ -757,8 +757,8 @@
(markup-env-expand (markup-stream-env rtf-stream) (markup-stream-unexpanded-output rtf-stream) nil))
(defmethod depict-block-style-f ((rtf-stream rtf-stream) block-style emitter)
(declare (ignore block-style))
(defmethod depict-block-style-f ((rtf-stream rtf-stream) block-style flatten emitter)
(declare (ignore block-style flatten))
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-paragraph-level*))
(funcall emitter rtf-stream))
@ -790,6 +790,10 @@
(rtf-stream-append-or-inline-block rtf-stream (markup-stream-unexpanded-output inner-rtf-stream)))))
(defmethod ensure-no-enclosing-style ((rtf-stream rtf-stream) style)
(declare (ignore style)))
(defmethod depict-anchor ((rtf-stream rtf-stream) link-prefix link-name duplicate)
(declare (ignore link-prefix link-name duplicate))
(assert-true (= (markup-stream-level rtf-stream) *markup-stream-content-level*)))