andros/emacs-gpu
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
v0.4.2
emacs-gpu/lisp/progmodes/ebnf2ps.el
T

6336 lines
181 KiB
EmacsLisp
Raw Permalink Blame History

;;; ebnf2ps.el --- translate an EBNF to a syntactic chart on PostScript -*- lexical-binding:t -*-
;; Copyright (C) 1999-2026 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Keywords: text, ebnf, PostScript
;; Old-Version: 4.4
;; URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Introduction
;; ------------
;;
;; This package translates an EBNF to a syntactic chart on PostScript.
;;
;; To use ebnf2ps, insert in your init file:
;;
;; (require 'ebnf2ps)
;;
;; ebnf2ps uses ps-print package (bundled with Emacs), so see ps-print to
;; know how to set options like landscape printing, page headings, margins,
;; etc.
;;
;; NOTE: ps-print zebra stripes and line number options don't have an
;; effect on ebnf2ps, they behave as if it's turned off.
;;
;;
;; Using ebnf2ps
;; -------------
;;
;; ebnf2ps provides the following commands for generating PostScript syntactic
;; chart images of Emacs buffers:
;;
;; ebnf-print-directory
;; ebnf-print-file
;; ebnf-print-buffer
;; ebnf-print-region
;; ebnf-spool-directory
;; ebnf-spool-file
;; ebnf-spool-buffer
;; ebnf-spool-region
;; ebnf-eps-directory
;; ebnf-eps-file
;; ebnf-eps-buffer
;; ebnf-eps-region
;;
;; These commands all perform essentially the same function: they generate
;; PostScript syntactic chart images suitable for printing on a PostScript
;; printer or displaying with GhostScript. These commands are collectively
;; referred to as "ebnf- commands".
;;
;; The word "print", "spool" and "eps" in the command name determines when the
;; PostScript image is sent to the printer (or file):
;;
;; print - The PostScript image is immediately sent to the printer;
;;
;; spool - The PostScript image is saved temporarily in an Emacs buffer.
;; Many images may be spooled locally before printing them. To
;; send the spooled images to the printer, use the command
;; `ebnf-despool'.
;;
;; eps - The PostScript image is immediately sent to an EPS file.
;;
;; The spooling mechanism is the same as used by ps-print and was designed for
;; printing lots of small files to save paper that would otherwise be wasted on
;; banner pages, and to make it easier to find your output at the printer (it's
;; easier to pick up one 50-page printout than to find 50 single-page
;; printouts). As ebnf2ps and ps-print use the same Emacs buffer to spool
;; images, you can intermix the spooling of ebnf2ps and ps-print images.
;;
;; ebnf2ps use the same hook of ps-print in the `kill-emacs-hook' so that you
;; won't accidentally quit from Emacs while you have unprinted PostScript
;; waiting in the spool buffer. If you do attempt to exit with spooled
;; PostScript, you'll be asked if you want to print it, and if you decline,
;; you'll be asked to confirm the exit; this is modeled on the confirmation
;; that Emacs uses for modified buffers.
;;
;; The word "directory", "file", "buffer" or "region" in the command name
;; determines how much of the buffer is printed:
;;
;; directory - Read files in the directory and print them.
;;
;; file - Read file and print it.
;;
;; buffer - Print the entire buffer.
;;
;; region - Print just the current region.
;;
;; Two ebnf- command examples:
;;
;; ebnf-print-buffer - translate and print the entire buffer, and send it
;; immediately to the printer.
;;
;; ebnf-spool-region - translate and print just the current region, and
;; spool the image in Emacs to send to the printer
;; later.
;;
;; Note that `ebnf-eps-directory', `ebnf-eps-file', `ebnf-eps-buffer' and
;; `ebnf-eps-region' never spool the EPS image, so they don't use the ps-print
;; spooling mechanism. See section "Actions in Comments" for an explanation
;; about EPS file generation.
;;
;;
;; Invoking Ebnf2ps
;; ----------------
;;
;; To translate and print your buffer, type
;;
;; M-x ebnf-print-buffer
;;
;; or substitute one of the other four ebnf- commands. The command will
;; generate the PostScript image and print or spool it as specified. By giving
;; the command a prefix argument
;;
;; C-u M-x ebnf-print-buffer
;;
;; it will save the PostScript image to a file instead of sending it to the
;; printer; you will be prompted for the name of the file to save the image to.
;; The prefix argument is ignored by the commands that spool their images, but
;; you may save the spooled images to a file by giving a prefix argument to
;; `ebnf-despool':
;;
;; C-u M-x ebnf-despool
;;
;; When invoked this way, `ebnf-despool' will prompt you for the name of the
;; file to save to.
;;
;; The prefix argument is also ignored by `ebnf-eps-buffer' and
;; `ebnf-eps-region'.
;;
;; Any of the `ebnf-' commands can be bound to keys. Here are some examples:
;;
;; (keymap-global-set "<f22>" #'ebnf-print-buffer) ;f22 is prsc
;; (keymap-global-set "S-<f22>" #'ebnf-print-region)
;; (keymap-global-set "C-<f22>" #'ebnf-despool)
;;
;;
;; Invoking Ebnf2ps in Batch
;; -------------------------
;;
;; It's possible also to run ebnf2ps in batch, this is useful when, for
;; example, you have a directory with a lot of files containing the EBNF to be
;; translated to PostScript.
;;
;; To run ebnf2ps in batch type, for example:
;;
;; emacs -batch -l setup-ebnf2ps.el -f ebnf-eps-directory
;;
;; Where setup-ebnf2ps.el should be a file containing:
;;
;; (require 'ebnf2ps)
;; ;; insert here your ebnf2ps settings
;; (setq ebnf-terminal-shape 'bevel)
;; ;; etc.
;;
;;
;; EBNF Syntax
;; -----------
;;
;; BNF (Backus Naur Form) notation is defined like languages, and like
;; languages there are rules about name formation and syntax. In this section
;; it's defined a BNF syntax that it's called simply EBNF (Extended BNF).
;; ebnf2ps package also deal with other BNF notation. Please, see the variable
;; `ebnf-syntax' documentation below in this section.
;;
;; The current EBNF that ebnf2ps accepts has the following constructions:
;;
;; ; comment (until end of line)
;; A non-terminal
;; "C" terminal
;; ?C? special
;; $A default non-terminal (see text below)
;; $"C" default terminal (see text below)
;; $?C? default special (see text below)
;; A = B. production (A is the header and B the body)
;; C D sequence (C occurs before D)
;; C | D alternative (C or D occurs)
;; A - B exception (A excluding B, B without any non-terminal)
;; n * A repetition (A repeats at least n (integer) times)
;; n * n A repetition (A repeats exactly n (integer) times)
;; n * m A repetition (A repeats at least n (integer) and at most
;; m (integer) times)
;; (C) group (expression C is grouped together)
;; [C] optional (C may or not occurs)
;; C+ one or more occurrences of C
;; {C}+ one or more occurrences of C
;; {C}* zero or more occurrences of C
;; {C} zero or more occurrences of C
;; C / D equivalent to: C {D C}*
;; {C || D}+ equivalent to: C {D C}*
;; {C || D}* equivalent to: [C {D C}*]
;; {C || D} equivalent to: [C {D C}*]
;;
;; The EBNF syntax written using the notation above is:
;;
;; EBNF = {production}+.
;;
;; production = non_terminal "=" body ".". ;; production
;;
;; body = {sequence || "|"}*. ;; alternative
;;
;; sequence = {exception}*. ;; sequence
;;
;; exception = repeat [ "-" repeat]. ;; exception
;;
;; repeat = [ integer "*" [ integer ]] term. ;; repetition
;;
;; term = factor
;; | [factor] "+" ;; one-or-more
;; | [factor] "/" [factor] ;; one-or-more
;; .
;;
;; factor = [ "$" ] "\"" terminal "\"" ;; terminal
;; | [ "$" ] non_terminal ;; non-terminal
;; | [ "$" ] "?" special "?" ;; special
;; | "(" body ")" ;; group
;; | "[" body "]" ;; zero-or-one
;; | "{" body [ "||" body ] "}+" ;; one-or-more
;; | "{" body [ "||" body ] "}*" ;; zero-or-more
;; | "{" body [ "||" body ] "}" ;; zero-or-more
;; .
;;
;; non_terminal = "[!#%&'*-,0-:<>@-Z\\\\^-z~\\240-\\377]+".
;; ;; that is, a valid non_terminal accepts decimal digits, letters (upper
;; ;; and lower), 8-bit accentuated characters,
;; ;; "!", "#", "%", "&", "'", "*", "+", ",", ":",
;; ;; "<", ">", "@", "\", "^", "_", "`" and "~".
;;
;; terminal = "\\([^\"\\]\\|\\\\[ -~\\240-\\377]\\)+".
;; ;; that is, a valid terminal accepts any printable character (including
;; ;; 8-bit accentuated characters) except `"', as `"' is used to delimit a
;; ;; terminal. Also, accepts escaped characters, that is, a character
;; ;; pair starting with `\' followed by a printable character, for
;; ;; example: \", \\.
;;
;; special = "[^?\\000-\\010\\012-\\037\\177-\\237]*".
;; ;; that is, a valid special accepts any printable character (including
;; ;; 8-bit accentuated characters) and tabs except `?', as `?' is used to
;; ;; delimit a special.
;;
;; integer = "[0-9]+".
;; ;; that is, an integer is a sequence of one or more decimal digits.
;;
;; comment = ";" "[^\\n\\000-\\010\\016-\\037\\177-\\237]*" "\\n".
;; ;; that is, a comment starts with the character `;' and terminates at end
;; ;; of line. Also, it only accepts printable characters (including 8-bit
;; ;; accentuated characters) and tabs.
;;
;; Try to use the above EBNF to test ebnf2ps.
;;
;; The `default' terminal, non-terminal and special is a way to indicate a
;; default path in a production. For example, the production:
;;
;; X = [ $A ( B | $C ) | D ].
;;
;; Indicates that the default meaning for "X" is "A C" if "X" is empty.
;;
;; The terminal name is controlled by `ebnf-terminal-regexp' and
;; `ebnf-case-fold-search', so it's possible to match other kind of terminal
;; name besides that enclosed by `"'.
;;
;; Let's see an example:
;;
;; (setq ebnf-terminal-regexp "[A-Z][_A-Z]*") ; upper case name
;; (setq ebnf-case-fold-search nil) ; exact matching
;;
;; If you have the production:
;;
;; Logical = "(" Expression ( OR | AND | "XOR" ) Expression ")".
;;
;; The names are classified as:
;;
;; Logical Expression non-terminal
;; "(" OR AND "XOR" ")" terminal
;;
;; The line comment is controlled by `ebnf-lex-comment-char'. The default
;; value is ?\; (character `;').
;;
;; The end of production is controlled by `ebnf-lex-eop-char'. The default
;; value is ?. (character `.').
;;
;; The variable `ebnf-syntax' specifies which syntax to recognize:
;;
;; `ebnf' ebnf2ps recognizes the syntax described above.
;; The following variables *ONLY* have effect with this
;; setting:
;; `ebnf-terminal-regexp', `ebnf-case-fold-search',
;; `ebnf-lex-comment-char' and `ebnf-lex-eop-char'.
;;
;; `abnf' ebnf2ps recognizes the syntax described in the URL:
;; `https://www.ietf.org/rfc/rfc2234.txt'
;; ("Augmented BNF for Syntax Specifications: ABNF").
;;
;; `iso-ebnf' ebnf2ps recognizes the syntax described in the URL:
;; `https://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html'
;; ("International Standard of the ISO EBNF Notation").
;; The following variables *ONLY* have effect with this
;; setting:
;; `ebnf-iso-alternative-p' and `ebnf-iso-normalize-p'.
;;
;; `yacc' ebnf2ps recognizes the Yacc/Bison syntax.
;; The following variable *ONLY* has effect with this
;; setting:
;; `ebnf-yac-ignore-error-recovery'.
;;
;; `ebnfx' ebnf2ps recognizes the syntax described in the URL:
;; `https://www.w3.org/TR/2004/REC-xml-20040204/#sec-notation'
;; ("Extensible Markup Language (XML) 1.0 (Third Edition)")
;;
;; `dtd' ebnf2ps recognizes the syntax described in the URL:
;; `https://www.w3.org/TR/2004/REC-xml-20040204/'
;; ("Extensible Markup Language (XML) 1.0 (Third Edition)")
;;
;; Any other value is treated as `ebnf'.
;;
;; The default value is `ebnf'.
;;
;;
;; Optimizations
;; -------------
;;
;; The following EBNF optimizations are done:
;;
;; [ { A }* ] ==> { A }*
;; [ { A }+ ] ==> { A }*
;; [ A ] + ==> { A }*
;; { A }* + ==> { A }*
;; { A }+ + ==> { A }+
;; { A }- ==> { A }+
;; [ A ]- ==> A
;; ( A | EMPTY )- ==> A
;; ( A | B | EMPTY )- ==> A | B
;; [ A | B ] ==> A | B | EMPTY
;; n * EMPTY ==> EMPTY
;; EMPTY + ==> EMPTY
;; EMPTY / EMPTY ==> EMPTY
;; EMPTY - A ==> EMPTY
;;
;; The following optimizations are done when `ebnf-optimize' is non-nil:
;;
;; left recursion:
;; 1. A = B | A C. ==> A = B {C}*.
;; 2. A = B | A B. ==> A = {B}+.
;; 3. A = | A B. ==> A = {B}*.
;; 4. A = B | A C B. ==> A = {B || C}+.
;; 5. A = B | D | A C | A E. ==> A = ( B | D ) { C | E }*.
;;
;; optional:
;; 6. A = B | . ==> A = [B].
;; 7. A = | B . ==> A = [B].
;;
;; factorization:
;; 8. A = B C | B D. ==> A = B (C | D).
;; 9. A = C B | D B. ==> A = (C | D) B.
;; 10. A = B C E | B D E. ==> A = B (C | D) E.
;;
;; The above optimizations are specially useful when `ebnf-syntax' is `yacc'.
;;
;;
;; Form Feed
;; ---------
;;
;; You may use form feed (^L \014) to force a production to start on a new
;; page, for example:
;;
;; a) A = B | C.
;; ^L
;; X = Y | Z.
;;
;; b) A = B ^L | C.
;; X = Y | Z.
;;
;; c) A = B ^L^L^L | C.^L
;; ^L
;; X = Y | Z.
;;
;; In all examples above, only the production X will start on a new page.
;;
;;
;; Actions in Comments
;; -------------------
;;
;; ebnf2ps accepts the following actions in comments:
;;
;; ;^ same as form feed. See section Form Feed above.
;;
;; ;> the next production starts in the same line as the current one.
;; It is useful when `ebnf-horizontal-orientation' is nil.
;;
;; ;< the next production starts in the next line.
;; It is useful when `ebnf-horizontal-orientation' is non-nil.
;;
;; ;[EPS open a new EPS file. The EPS file name has the form:
;; <PREFIX><NAME>.eps
;; where <PREFIX> is given by variable `ebnf-eps-prefix' and
;; <NAME> is the string given by ;[ action comment, this string is
;; mapped to form a valid file name (see documentation for
;; `ebnf-eps-buffer' or `ebnf-eps-region').
;; It has effect only during `ebnf-eps-buffer' or
;; `ebnf-eps-region' execution.
;; It's an error to try to open an already opened EPS file.
;;
;; ;]EPS close an opened EPS file.
;; It has effect only during `ebnf-eps-buffer' or
;; `ebnf-eps-region' execution.
;; It's an error to try to close a not opened EPS file.
;;
;; ;Hheader generate a header in current EPS file. The header string can
;; have the following formats:
;;
;; %% prints a % character.
;;
;; %H prints the `ebnf-eps-header' (which see) value.
;;
;; %F prints the `ebnf-eps-footer' (which see) value.
;;
;; Any other format is ignored, that is, if, for example, it's
;; used %s then %s characters are stripped out from the header.
;; If header is an empty string, no header is generated until a
;; non-empty header is specified or `ebnf-eps-header' has a
;; non-empty string value.
;;
;; ;Ffooter generate a footer in current EPS file. Similar to ;H action
;; comment.
;;
;; So if you have:
;;
;; (setq ebnf-horizontal-orientation nil)
;;
;; A = t.
;; C = x.
;; ;> C and B are drawn in the same line
;; B = y.
;; W = v.
;;
;; The graphical result is:
;;
;; +---+
;; | A |
;; +---+
;;
;; +---------+ +-----+
;; | | | |
;; | C | | |
;; | | | B |
;; +---------+ | |
;; | |
;; +-----+
;;
;; +-----------+
;; | W |
;; +-----------+
;;
;; Note that if ascending production sort is used, the productions A and B will
;; be drawn in the same line instead of C and B.
;;
;; If consecutive actions occur, only the last one takes effect, so if you
;; have:
;;
;; A = X.
;; ;<
;; ^L
;; ;>
;; B = Y.
;;
;; Only the ;> will take effect, that is, A and B will be drawn in the same
;; line.
;;
;; In ISO EBNF the above actions are specified as (*^*), (*>*), (*<*), (*[EPS*)
;; and (*]EPS*). The first example above should be written:
;;
;; A = t;
;; C = x;
;; (*> C and B are drawn in the same line *)
;; B = y;
;; W = v;
;;
;; For an example of EPS action when executing `ebnf-eps-buffer' or
;; `ebnf-eps-region':
;;
;; Z = B0.
;; ;[CC
;; ;[AA
;; A = B1.
;; ;[BB
;; C = B2.
;; ;]AA
;; B = B3.
;; ;]BB
;; ;]CC
;; D = B4.
;; E = B5.
;; ;[CC
;; F = B6.
;; ;]CC
;; G = B7.
;;
;; The following table summarizes the results:
;;
;; EPS FILE NAME NO SORT ASCENDING SORT DESCENDING SORT
;; ebnf--AA.eps A C A C C A
;; ebnf--BB.eps C B B C C B
;; ebnf--CC.eps A C B F A B C F F C B A
;; ebnf--D.eps D D D
;; ebnf--E.eps E E E
;; ebnf--G.eps G G G
;; ebnf--Z.eps Z Z Z
;;
;; As you can see if EPS actions is not used, each single production is
;; generated per EPS file. To avoid overriding EPS files, use names in ;[ that
;; it's not an existing production name.
;;
;; In the following case:
;;
;; A = B0.
;; ;[AA
;; A = B1.
;; ;[BB
;; A = B2.
;;
;; The production A is generated in both files ebnf--AA.eps and ebnf--BB.eps.
;;
;;
;; Log Messages
;; ------------
;;
;; The buffer *Ebnf2ps Log* is where the ebnf2ps log messages are inserted.
;; These messages are intended to help debugging ebnf2ps.
;;
;; The log messages are enabled by `ebnf-log' option (which see). The default
;; value is nil, that is, no log messages are generated.
;;
;;
;; Utilities
;; ---------
;;
;; Some tools are provided to help you.
;;
;; `ebnf-setup' returns the current setup.
;;
;; `ebnf-syntax-directory' does a syntactic analysis of your EBNF files in the
;; given directory.
;;
;; `ebnf-syntax-file' does a syntactic analysis of your EBNF in the given
;; file.
;;
;; `ebnf-syntax-buffer' does a syntactic analysis of your EBNF in the current
;; buffer.
;;
;; `ebnf-syntax-region' does a syntactic analysis of your EBNF in the current
;; region.
;;
;; `ebnf-customize' activates a customization buffer for ebnf2ps options.
;;
;; `ebnf-syntax-directory', `ebnf-syntax-file', `ebnf-syntax-buffer',
;; `ebnf-syntax-region' and `ebnf-customize' can be bound to keys in the same
;; way as `ebnf-' commands.
;;
;;
;; Hooks
;; -----
;;
;; ebn2ps has the following hook variables:
;;
;; `ebnf-hook'
;; It is evaluated once before any ebnf2ps process.
;;
;; `ebnf-production-hook'
;; It is evaluated on each beginning of production.
;;
;; `ebnf-page-hook'
;; It is evaluated on each beginning of page.
;;
;;
;; Options
;; -------
;;
;; Below it's shown a brief description of ebnf2ps options, please, see the
;; options declaration in the code for a long documentation.
;;
;; `ebnf-horizontal-orientation' Non-nil means productions are drawn
;; horizontally.
;;
;; `ebnf-horizontal-max-height' Non-nil means to use maximum production
;; height in horizontal orientation.
;;
;; `ebnf-production-horizontal-space' Specify horizontal space in points
;; between productions.
;;
;; `ebnf-production-vertical-space' Specify vertical space in points
;; between productions.
;;
;; `ebnf-justify-sequence' Specify justification of terms in a
;; sequence inside alternatives.
;;
;; `ebnf-terminal-regexp' Specify how it's a terminal name.
;;
;; `ebnf-case-fold-search' Non-nil means ignore case on matching.
;;
;; `ebnf-terminal-font' Specify terminal font.
;;
;; `ebnf-terminal-shape' Specify terminal box shape.
;;
;; `ebnf-terminal-shadow' Non-nil means terminal box will have a
;; shadow.
;;
;; `ebnf-terminal-border-width' Specify border width for terminal box.
;;
;; `ebnf-terminal-border-color' Specify border color for terminal box.
;;
;; `ebnf-production-name-p' Non-nil means production name will be
;; printed.
;;
;; `ebnf-sort-production' Specify how productions are sorted.
;;
;; `ebnf-production-font' Specify production font.
;;
;; `ebnf-non-terminal-font' Specify non-terminal font.
;;
;; `ebnf-non-terminal-shape' Specify non-terminal box shape.
;;
;; `ebnf-non-terminal-shadow' Non-nil means non-terminal box will
;; have a shadow.
;;
;; `ebnf-non-terminal-border-width' Specify border width for non-terminal
;; box.
;;
;; `ebnf-non-terminal-border-color' Specify border color for non-terminal
;; box.
;;
;; `ebnf-special-show-delimiter' Non-nil means special delimiter
;; (character `?') is shown.
;;
;; `ebnf-special-font' Specify special font.
;;
;; `ebnf-special-shape' Specify special box shape.
;;
;; `ebnf-special-shadow' Non-nil means special box will have a
;; shadow.
;;
;; `ebnf-special-border-width' Specify border width for special box.
;;
;; `ebnf-special-border-color' Specify border color for special box.
;;
;; `ebnf-except-font' Specify except font.
;;
;; `ebnf-except-shape' Specify except box shape.
;;
;; `ebnf-except-shadow' Non-nil means except box will have a
;; shadow.
;;
;; `ebnf-except-border-width' Specify border width for except box.
;;
;; `ebnf-except-border-color' Specify border color for except box.
;;
;; `ebnf-repeat-font' Specify repeat font.
;;
;; `ebnf-repeat-shape' Specify repeat box shape.
;;
;; `ebnf-repeat-shadow' Non-nil means repeat box will have a
;; shadow.
;;
;; `ebnf-repeat-border-width' Specify border width for repeat box.
;;
;; `ebnf-repeat-border-color' Specify border color for repeat box.
;;
;; `ebnf-entry-percentage' Specify entry height on alternatives.
;;
;; `ebnf-arrow-shape' Specify the arrow shape.
;;
;; `ebnf-chart-shape' Specify chart flow shape.
;;
;; `ebnf-color-p' Non-nil means use color.
;;
;; `ebnf-line-width' Specify flow line width.
;;
;; `ebnf-line-color' Specify flow line color.
;;
;; `ebnf-arrow-extra-width' Specify extra width for arrow shape
;; drawing.
;;
;; `ebnf-arrow-scale' Specify the arrow scale.
;;
;; `ebnf-user-arrow' Specify a sexp for user arrow shape (a
;; PostScript code).
;;
;; `ebnf-debug-ps' Non-nil means to generate PostScript
;; debug procedures.
;;
;; `ebnf-lex-comment-char' Specify the line comment character.
;;
;; `ebnf-lex-eop-char' Specify the end of production
;; character.
;;
;; `ebnf-syntax' Specify syntax to be recognized.
;;
;; `ebnf-iso-alternative-p' Non-nil means use alternative ISO EBNF.
;;
;; `ebnf-iso-normalize-p' Non-nil means normalize ISO EBNF syntax
;; names.
;;
;; `ebnf-default-width' Specify additional border width over
;; default terminal, non-terminal or
;; special.
;;
;; `ebnf-file-suffix-regexp' Specify file name suffix that contains
;; EBNF.
;;
;; `ebnf-eps-prefix' Specify EPS prefix file name.
;;
;; `ebnf-eps-header-font' Specify EPS header font.
;;
;; `ebnf-eps-header' Specify EPS header.
;;
;; `ebnf-eps-footer-font' Specify EPS footer font.
;;
;; `ebnf-eps-footer' Specify EPS footer.
;;
;; `ebnf-use-float-format' Non-nil means use `%f' float format.
;;
;; `ebnf-stop-on-error' Non-nil means signal error and stop.
;; Nil means signal error and continue.
;;
;; `ebnf-yac-ignore-error-recovery' Non-nil means ignore error recovery.
;;
;; `ebnf-ignore-empty-rule' Non-nil means ignore empty rules.
;;
;; `ebnf-optimize' Non-nil means optimize syntactic chart
;; of rules.
;;
;; `ebnf-log' Non-nil means generate log messages.
;;
;; To set the above options you may:
;;
;; a) insert the code in your init file, like:
;;
;; (setq ebnf-terminal-shape 'bevel)
;;
;; This way always keep your default settings when you enter a new Emacs
;; session.
;;
;; b) or use `set-variable' in your Emacs session, like:
;;
;; M-x set-variable RET ebnf-terminal-shape RET bevel RET
;;
;; This way keep your settings only during the current Emacs session.
;;
;; c) or use customization, for example:
;; click on menu-bar *Help* option,
;; then click on *Customize*,
;; then click on *Browse Customization Groups*,
;; expand *PostScript* group,
;; expand *Ebnf2ps* group
;; and then customize ebnf2ps options.
;; Through this way, you may choose if the settings are kept or not when
;; you leave out the current Emacs session.
;;
;; d) or see the option value:
;;
;; C-h v ebnf-terminal-shape RET
;;
;; and click the *customize* hypertext button.
;; Through this way, you may choose if the settings are kept or not when
;; you leave out the current Emacs session.
;;
;; e) or invoke:
;;
;; M-x ebnf-customize RET
;;
;; and then customize ebnf2ps options.
;; Through this way, you may choose if the settings are kept or not when
;; you leave out the current Emacs session.
;;
;;
;; Styles
;; ------
;;
;; Sometimes you need to change the EBNF style you are using, for example,
;; change the shapes and colors. These changes may force you to set some
;; variables and after use, set back the variables to the old values.
;;
;; To help to handle this situation, ebnf2ps has the following commands to
;; handle styles:
;;
;; `ebnf-find-style' Return style definition if NAME is already defined;
;; otherwise, return nil.
;;
;; `ebnf-insert-style' Insert a new style NAME with inheritance INHERITS and
;; values VALUES.
;;
;; `ebnf-delete-style' Delete style NAME.
;;
;; `ebnf-merge-style' Merge values of style NAME with style VALUES.
;;
;; `ebnf-apply-style' Set STYLE as the current style.
;;
;; `ebnf-reset-style' Reset current style.
;;
;; `ebnf-push-style' Push the current style and set STYLE as the current
;; style.
;;
;; `ebnf-pop-style' Pop a style and set it as the current style.
;;
;; These commands help to put together a lot of variable settings in a group
;; and name this group. So when you wish to apply these settings it's only
;; needed to give the name.
;;
;; There is also a notion of simple inheritance of style: if you declare that
;; style A inherits from style B, all settings of B are applied first and then
;; the settings of A are applied. This is useful when you wish to modify some
;; aspects of an existing style, but at same time wish to keep it unmodified.
;;
;; See documentation for `ebnf-style-database'.
;;
;;
;; Layout
;; ------
;;
;; Below it is the layout of minimum area to draw each element, and it's used
;; the following terms:
;;
;; font height is given by:
;; (terminal font height + non-terminal font height) / 2
;;
;; entry is the vertical position used to know where it should
;; be drawn the flow line in the current element.
;;
;; extra is given by `ebnf-arrow-extra-width'.
;;
;;
;; * SPECIAL, TERMINAL and NON-TERMINAL
;;
;; +==============+...................................
;; | | } font height / 2 } entry }
;; | XXXXXXXX...|....... } }
;; ====+ XXXXXXXX +==== } text height ...... } height
;; : | XXXXXXXX...|...:... }
;; : | : : | : } font height / 2 }
;; : +==============+...:...............................
;; : : : : : :
;; : : : : : :.........................
;; : : : : : } font height }
;; : : : : :....... }
;; : : : : } font height / 2 }
;; : : : :........... }
;; : : : } text width } width
;; : : :.................. }
;; : : } font height / 2 }
;; : :...................... }
;; : } font height + extra }
;; :.................................................
;;
;;
;; * OPTIONAL
;;
;; +==========+.....................................
;; | | } } }
;; | | } entry } }
;; | | } } }
;; ===+===+ +===+===... } element height } height
;; : \ | | / : } }
;; : + | | + : } }
;; : | +==========+.|................. }
;; : | : : | : } font height }
;; : +==============+...................................
;; : : : :
;; : : : :......................
;; : : : } font height * 2 }
;; : : :.......... }
;; : : } element width } width
;; : :..................... }
;; : } font height * 2 }
;; :...............................................
;;
;;
;; * ALTERNATIVE
;;
;; +===+...................................
;; +==+ A +==+ } A height } }
;; | +===+..|........ } entry }
;; + + } font height } }
;; / +===+...\....... } }
;; ===+====+ B +====+=== } B height ..... } height
;; : \ +===+.../....... }
;; : + + : } font height }
;; : | +===+..|........ }
;; : +==+ C +==+ : } C height }
;; : : +===+...................................
;; : : : :
;; : : : :......................
;; : : : } font height * 2 }
;; : : :......... }
;; : : } max width } width
;; : :................. }
;; : } font height * 2 }
;; :..........................................
;;
;; NOTES:
;; 1. An empty alternative has zero of height.
;;
;; 2. The variable `ebnf-entry-percentage' is used to determine the
;; entry point.
;;
;;
;; * ZERO OR MORE
;;
;; +===========+...............................
;; +=+ separator +=+ } separator height }
;; / +===========+..\........ }
;; + + } }
;; | | } font height }
;; + + } }
;; \ +===========+../........ } height = entry
;; +=+ element +=+ } element height }
;; /: +===========+..\........ }
;; + : : + } }
;; + : : + } font height }
;; / : : \ } }
;; ==+=======================+==.......................
;; : : : :
;; : : : :.......................
;; : : : } font height * 2 }
;; : : :......... }
;; : : } max width } width
;; : :......................... }
;; : } font height * 2 }
;; :...................................................
;;
;;
;; * ONE OR MORE
;;
;; +===========+......................................
;; +=+ separator +=+ } separator height } }
;; / +===========+..\...... } }
;; + + } } entry }
;; | | } font height } } height
;; + + } } }
;; \ +===========+../...... } }
;; ===+=+ element +=+=== } element height .... }
;; : : +===========+......................................
;; : : : :
;; : : : :........................
;; : : : } font height * 2 }
;; : : :....... }
;; : : } max width } width
;; : :....................... }
;; : } font height * 2 }
;; :..............................................
;;
;;
;; * PRODUCTION
;;
;; XXXXXX:......................................
;; XXXXXX: } production font height }
;; XXXXXX:............ }
;; } font height }
;; +======+....... } height = entry
;; | | } }
;; ====+ +==== } element height }
;; : | | : } }
;; : +======+.................................
;; : : : :
;; : : : :......................
;; : : : } font height * 2 }
;; : : :....... }
;; : : } element width } width
;; : :.............. }
;; : } font height * 2 }
;; :.....................................
;;
;;
;; * REPEAT
;;
;; +================+...................................
;; | | } font height / 2 } entry }
;; | +===+...|....... } }
;; ====+ N * | X | +==== } X height ......... } height
;; : | : : +===+...|...:... }
;; : | : : : : | : } font height / 2 }
;; : +================+...:...............................
;; : : : : : : : :
;; : : : : : : : :..........................
;; : : : : : : : } font height }
;; : : : : : : :....... }
;; : : : : : : } font height / 2 }
;; : : : : : :........... }
;; : : : : : } X width }
;; : : : : :............... }
;; : : : : } font height / 2 } width
;; : : : :.................. }
;; : : : } text width }
;; : : :..................... }
;; : : } font height / 2 }
;; : :........................ }
;; : } font height + extra }
;; :...................................................
;;
;;
;; * EXCEPT
;;
;; +==================+...................................
;; | | } font height / 2 } entry }
;; | +===+ +===+...|....... } }
;; ====+ | X | - | y | +==== } max height ....... } height
;; : | +===+ +===+...|...:... }
;; : | : : : : | : } font height / 2 }
;; : +==================+...:...............................
;; : : : : : : : :
;; : : : : : : : :..........................
;; : : : : : : : } font height }
;; : : : : : : :....... }
;; : : : : : : } font height / 2 }
;; : : : : : :........... }
;; : : : : : } Y width }
;; : : : : :............... }
;; : : : : } font height } width
;; : : : :................... }
;; : : : } X width }
;; : : :....................... }
;; : : } font height / 2 }
;; : :.......................... }
;; : } font height + extra }
;; :.....................................................
;;
;; NOTE: If Y element is empty, it's draw nothing at Y place.
;;
;;
;; Internal Structures
;; -------------------
;;
;; ebnf2ps has two passes. The first pass does a lexical and syntactic analysis
;; of current buffer and generates an intermediate representation. The second
;; pass uses the intermediate representation to generate the PostScript
;; syntactic chart.
;;
;; The intermediate representation is a list of vectors, the vector element
;; represents a syntactic chart element. Below is a vector representation for
;; each syntactic chart element.
;;
;; [production WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH NAME PRODUCTION ACTION]
;; [alternative WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH LIST]
;; [sequence WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH LIST]
;; [terminal WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH NAME DEFAULT]
;; [non-terminal WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH NAME DEFAULT]
;; [special WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH NAME DEFAULT]
;; [empty WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH]
;; [optional WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH ELEMENT]
;; [one-or-more WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH ELEMENT SEPARATOR]
;; [zero-or-more WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH ELEMENT SEPARATOR]
;; [repeat WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH TIMES ELEMENT]
;; [except WIDTH-FUN DIM-FUN ENTRY HEIGHT WIDTH ELEMENT ELEMENT]
;;
;; The first vector position is a function symbol used to generate PostScript
;; for this element.
;; WIDTH-FUN is a function symbol called to adjust the element width.
;; DIM-FUN is a function symbol called to set the element dimensions.
;; ENTRY is the element entry point.
;; HEIGHT and WIDTH are the element height and width, respectively.
;; NAME is a string that it's the element name.
;; DEFAULT is a boolean that indicates if it's a `default' element.
;; PRODUCTION and ELEMENT are vectors that represents sub-elements of current
;; one.
;; LIST is a list of vector that represents the list part for alternatives and
;; sequences.
;; SEPARATOR is a vector that represents the sub-element used to separate the
;; list elements.
;; TIMES is a string representing the number of times that ELEMENT is repeated
;; on a repeat construction.
;; ACTION indicates some action that should be done before production is
;; generated. The current actions are:
;;
;; nil no action.
;;
;; form-feed current production starts on a new page.
;;
;; newline current production starts on next line, this is useful
;; when `ebnf-horizontal-orientation' is non-nil.
;;
;; keep-line current production continues on the current line, this
;; is useful when `ebnf-horizontal-orientation' is nil.
;;
;;
;; Things To Change
;; ----------------
;;
;; . Handle situations when syntactic chart is out of paper.
;; . Use other alphabet than ascii.
;; . Optimizations...
;;
;;
;; Acknowledgments
;; ---------------
;;
;; Thanks to Eli Zaretskii <eliz@gnu.org> for some doc fixes.
;;
;; Thanks to Drew Adams <drew.adams@oracle.com> for suggestions:
;; - `ebnf-arrow-extra-width', `ebnf-arrow-scale',
;; `ebnf-production-name-p', `ebnf-stop-on-error',
;; `ebnf-file-suffix-regexp' and `ebnf-special-show-delimiter' variables.
;; - `ebnf-delete-style', `ebnf-eps-file' and `ebnf-eps-directory'
;; commands.
;; - some docs fix.
;;
;; Thanks to Matthew K. Junker <junker@alum.mit.edu> for the suggestion to deal
;; with some Bison features (%right, %left and %prec pragmas). His suggestion
;; was extended to deal with %nonassoc pragma too.
;;
;; Thanks to all who emailed comments.
;;
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Code:
(require 'ps-print)
(eval-when-compile (require 'cl-lib))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User Variables:
;;; Interface to the command system
(defgroup postscript nil
"Printing with PostScript."
:tag "PostScript"
:version "20"
:group 'environment)
(defgroup ebnf2ps nil
"Translate an EBNF to a syntactic chart on PostScript."
:prefix "ebnf-"
:version "20"
:group 'text
:group 'postscript)
(defgroup ebnf-special nil
"Special customization."
:prefix "ebnf-"
:tag "Special"
:version "20"
:group 'ebnf2ps)
(defgroup ebnf-except nil
"Except customization."
:prefix "ebnf-"
:tag "Except"
:version "20"
:group 'ebnf2ps)
(defgroup ebnf-repeat nil
"Repeat customization."
:prefix "ebnf-"
:tag "Repeat"
:version "20"
:group 'ebnf2ps)
(defgroup ebnf-terminal nil
"Terminal customization."
:prefix "ebnf-"
:tag "Terminal"
:version "20"
:group 'ebnf2ps)
(defgroup ebnf-non-terminal nil
"Non-Terminal customization."
:prefix "ebnf-"
:tag "Non-Terminal"
:version "20"
:group 'ebnf2ps)
(defgroup ebnf-production nil
"Production customization."
:prefix "ebnf-"
:tag "Production"
:version "20"
:group 'ebnf2ps)
(defgroup ebnf-shape nil
"Shapes customization."
:prefix "ebnf-"
:tag "Shape"
:version "20"
:group 'ebnf2ps)
(defgroup ebnf-displacement nil
"Displacement customization."
:prefix "ebnf-"
:tag "Displacement"
:version "20"
:group 'ebnf2ps)
(defgroup ebnf-syntactic nil
"Syntactic customization."
:prefix "ebnf-"
:tag "Syntactic"
:version "20"
:group 'ebnf2ps)
(defgroup ebnf-optimization nil
"Optimization customization."
:prefix "ebnf-"
:tag "Optimization"
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-horizontal-orientation nil
"Non-nil means productions are drawn horizontally."
:type 'boolean
:version "20"
:group 'ebnf-displacement)
(defcustom ebnf-horizontal-max-height nil
"Non-nil means to use maximum production height in horizontal orientation.
It is only used when `ebnf-horizontal-orientation' is non-nil."
:type 'boolean
:version "20"
:group 'ebnf-displacement)
(defcustom ebnf-production-horizontal-space 0.0 ; use ebnf2ps default value
"Specify horizontal space in points between productions.
Value less or equal to zero forces ebnf2ps to set a proper default value."
:type 'number
:version "20"
:group 'ebnf-displacement)
(defcustom ebnf-production-vertical-space 0.0 ; use ebnf2ps default value
"Specify vertical space in points between productions.
Value less or equal to zero forces ebnf2ps to set a proper default value."
:type 'number
:version "20"
:group 'ebnf-displacement)
(defcustom ebnf-justify-sequence 'center
"Specify justification of terms in a sequence inside alternatives.
Valid values are:
`left' left justification
`right' right justification
any other value centralize"
:type '(radio :tag "Sequence Justification"
(const left) (const right) (other :tag "center" center))
:version "20"
:group 'ebnf-displacement)
(defcustom ebnf-special-show-delimiter t
"Non-nil means special delimiter (character `?') is shown."
:type 'boolean
:version "20"
:group 'ebnf-special)
(defcustom ebnf-special-font '(7 Courier "Black" "Gray95" bold italic)
"Specify special font.
See documentation for `ebnf-production-font'."
:type '(list :tag "Special Font"
(number :tag "Font Size")
(symbol :tag "Font Name")
(choice :tag "Foreground Color"
(string :tag "Name")
(other :tag "Default" nil))
(choice :tag "Background Color"
(string :tag "Name")
(other :tag "Default" nil))
(repeat :tag "Font Attributes" :inline t
(choice (const bold) (const italic)
(const underline) (const strikeout)
(const overline) (const shadow)
(const box) (const outline))))
:version "20"
:group 'ebnf-special)
(defcustom ebnf-special-shape 'bevel
"Specify special box shape.
See documentation for `ebnf-non-terminal-shape'."
:type '(radio :tag "Special Shape"
(const miter) (const round) (const bevel))
:version "20"
:group 'ebnf-special)
(defcustom ebnf-special-shadow nil
"Non-nil means special box will have a shadow."
:type 'boolean
:version "20"
:group 'ebnf-special)
(defcustom ebnf-special-border-width 0.5
"Specify border width for special box."
:type 'number
:version "20"
:group 'ebnf-special)
(defcustom ebnf-special-border-color "Black"
"Specify border color for special box."
:type 'string
:version "20"
:group 'ebnf-special)
(defcustom ebnf-except-font '(7 Courier "Black" "Gray90" bold italic)
"Specify except font.
See documentation for `ebnf-production-font'."
:type '(list :tag "Except Font"
(number :tag "Font Size")
(symbol :tag "Font Name")
(choice :tag "Foreground Color"
(string :tag "Name")
(other :tag "Default" nil))
(choice :tag "Background Color"
(string :tag "Name")
(other :tag "Default" nil))
(repeat :tag "Font Attributes" :inline t
(choice (const bold) (const italic)
(const underline) (const strikeout)
(const overline) (const shadow)
(const box) (const outline))))
:version "20"
:group 'ebnf-except)
(defcustom ebnf-except-shape 'bevel
"Specify except box shape.
See documentation for `ebnf-non-terminal-shape'."
:type '(radio :tag "Except Shape"
(const miter) (const round) (const bevel))
:version "20"
:group 'ebnf-except)
(defcustom ebnf-except-shadow nil
"Non-nil means except box will have a shadow."
:type 'boolean
:version "20"
:group 'ebnf-except)
(defcustom ebnf-except-border-width 0.25
"Specify border width for except box."
:type 'number
:version "20"
:group 'ebnf-except)
(defcustom ebnf-except-border-color "Black"
"Specify border color for except box."
:type 'string
:version "20"
:group 'ebnf-except)
(defcustom ebnf-repeat-font '(7 Courier "Black" "Gray85" bold italic)
"Specify repeat font.
See documentation for `ebnf-production-font'."
:type '(list :tag "Repeat Font"
(number :tag "Font Size")
(symbol :tag "Font Name")
(choice :tag "Foreground Color"
(string :tag "Name")
(other :tag "Default" nil))
(choice :tag "Background Color"
(string :tag "Name")
(other :tag "Default" nil))
(repeat :tag "Font Attributes" :inline t
(choice (const bold) (const italic)
(const underline) (const strikeout)
(const overline) (const shadow)
(const box) (const outline))))
:version "20"
:group 'ebnf-repeat)
(defcustom ebnf-repeat-shape 'bevel
"Specify repeat box shape.
See documentation for `ebnf-non-terminal-shape'."
:type '(radio :tag "Repeat Shape"
(const miter) (const round) (const bevel))
:version "20"
:group 'ebnf-repeat)
(defcustom ebnf-repeat-shadow nil
"Non-nil means repeat box will have a shadow."
:type 'boolean
:version "20"
:group 'ebnf-repeat)
(defcustom ebnf-repeat-border-width 0.0
"Specify border width for repeat box."
:type 'number
:version "20"
:group 'ebnf-repeat)
(defcustom ebnf-repeat-border-color "Black"
"Specify border color for repeat box."
:type 'string
:version "20"
:group 'ebnf-repeat)
(defcustom ebnf-terminal-font '(7 Courier "Black" "White")
"Specify terminal font.
See documentation for `ebnf-production-font'."
:type '(list :tag "Terminal Font"
(number :tag "Font Size")
(symbol :tag "Font Name")
(choice :tag "Foreground Color"
(string :tag "Name")
(other :tag "Default" nil))
(choice :tag "Background Color"
(string :tag "Name")
(other :tag "Default" nil))
(repeat :tag "Font Attributes" :inline t
(choice (const bold) (const italic)
(const underline) (const strikeout)
(const overline) (const shadow)
(const box) (const outline))))
:version "20"
:group 'ebnf-terminal)
(defcustom ebnf-terminal-shape 'miter
"Specify terminal box shape.
See documentation for `ebnf-non-terminal-shape'."
:type '(radio :tag "Terminal Shape"
(const miter) (const round) (const bevel))
:version "20"
:group 'ebnf-terminal)
(defcustom ebnf-terminal-shadow nil
"Non-nil means terminal box will have a shadow."
:type 'boolean
:version "20"
:group 'ebnf-terminal)
(defcustom ebnf-terminal-border-width 1.0
"Specify border width for terminal box."
:type 'number
:version "20"
:group 'ebnf-terminal)
(defcustom ebnf-terminal-border-color "Black"
"Specify border color for terminal box."
:type 'string
:version "20"
:group 'ebnf-terminal)
(defcustom ebnf-production-name-p t
"Non-nil means production name will be printed."
:type 'boolean
:version "20"
:group 'ebnf-production)
(defcustom ebnf-sort-production nil
"Specify how productions are sorted.
Valid values are:
nil don't sort productions.
`ascending' ascending sort.
any other value descending sort."
:type '(radio :tag "Production Sort"
(const :tag "Ascending" ascending)
(const :tag "Descending" descending)
(other :tag "No Sort" nil))
:version "20"
:group 'ebnf-production)
(defcustom ebnf-production-font '(10 Helvetica "Black" "White" bold)
"Specify production header font.
It is a list with the following form:
(SIZE NAME FOREGROUND BACKGROUND ATTRIBUTE...)
Where:
SIZE is the font size.
NAME is the font name symbol.
ATTRIBUTE is one of the following symbols:
bold - use bold font.
italic - use italic font.
underline - put a line under text.
strikeout - like underline, but the line is in middle of text.
overline - like underline, but the line is over the text.
shadow - text will have a shadow.
box - text will be surrounded by a box.
outline - print characters as hollow outlines.
FOREGROUND is a foreground string color name; if it's nil, the default color is
\"Black\".
BACKGROUND is a background string color name; if it's nil, the default color is
\"White\".
See `ps-font-info-database' for valid font name."
:type '(list :tag "Production Font"
(number :tag "Font Size")
(symbol :tag "Font Name")
(choice :tag "Foreground Color"
(string :tag "Name")
(other :tag "Default" nil))
(choice :tag "Background Color"
(string :tag "Name")
(other :tag "Default" nil))
(repeat :tag "Font Attributes" :inline t
(choice (const bold) (const italic)
(const underline) (const strikeout)
(const overline) (const shadow)
(const box) (const outline))))
:version "20"
:group 'ebnf-production)
(defcustom ebnf-non-terminal-font '(7 Helvetica "Black" "White")
"Specify non-terminal font.
See documentation for `ebnf-production-font'."
:type '(list :tag "Non-Terminal Font"
(number :tag "Font Size")
(symbol :tag "Font Name")
(choice :tag "Foreground Color"
(string :tag "Name")
(other :tag "Default" nil))
(choice :tag "Background Color"
(string :tag "Name")
(other :tag "Default" nil))
(repeat :tag "Font Attributes" :inline t
(choice (const bold) (const italic)
(const underline) (const strikeout)
(const overline) (const shadow)
(const box) (const outline))))
:version "20"
:group 'ebnf-non-terminal)
(defcustom ebnf-non-terminal-shape 'round
"Specify non-terminal box shape.
Valid values are:
`miter' +-------+
| |
+-------+
`round' -------
( )
-------
`bevel' /-------\\
| |
\\-------/
Any other value is treated as `miter'."
:type '(radio :tag "Non-Terminal Shape"
(const miter) (const round) (const bevel))
:version "20"
:group 'ebnf-non-terminal)
(defcustom ebnf-non-terminal-shadow nil
"Non-nil means non-terminal box will have a shadow."
:type 'boolean
:version "20"
:group 'ebnf-non-terminal)
(defcustom ebnf-non-terminal-border-width 1.0
"Specify border width for non-terminal box."
:type 'number
:version "20"
:group 'ebnf-non-terminal)
(defcustom ebnf-non-terminal-border-color "Black"
"Specify border color for non-terminal box."
:type 'string
:version "20"
:group 'ebnf-non-terminal)
(defcustom ebnf-arrow-shape 'hollow
"Specify the arrow shape.
Valid values are:
`none' ======
`semi-up' * `transparent' *
* |*
=====* | *
==+==*
| *
|*
*
`semi-down' =====* `hollow' *
* |*
* | *
==+ *
| *
|*
*
`simple' * `full' *
* |*
=====* |X*
* ==+XX*
* |X*
|*
*
`semi-up-hollow' `semi-up-full'
* *
|* |*
| * |X*
==+==* ==+==*
`semi-down-hollow' `semi-down-full'
==+==* ==+==*
| * |X*
|* |*
* *
`user' See also documentation for variable `ebnf-user-arrow'.
Any other value is treated as `none'."
:type '(radio :tag "Arrow Shape"
(const none) (const semi-up)
(const semi-down) (const simple)
(const transparent) (const hollow)
(const full) (const semi-up-hollow)
(const semi-down-hollow) (const semi-up-full)
(const semi-down-full) (const user))
:version "20"
:group 'ebnf-shape)
(defcustom ebnf-chart-shape 'round
"Specify chart flow shape.
See documentation for `ebnf-non-terminal-shape'."
:type '(radio :tag "Chart Flow Shape"
(const miter) (const round) (const bevel))
:version "20"
:group 'ebnf-shape)
(defcustom ebnf-user-arrow nil
"Specify a sexp for user arrow shape (a PostScript code).
When evaluated, the sexp should return nil or a string containing PostScript
code. PostScript code should draw a right arrow.
The anatomy of a right arrow is:
...... Initial position
:
: *.................
: | * } }
: | * } hT4 }
v | * } }
======+======*... } hT2
: | *: } }
: | * : } hT4 }
: | * : } }
: *.................
: : :
: : :..........
: : } hT2 }
: :.......... } hT
: } hT2 }
:.......................
Where `hT', `hT2' and `hT4' are predefined PostScript variable names that can
be used to generate your own arrow. As these variables are used along
PostScript execution, *DON'T* modify the values of them. Instead, copy the
values, if you need to modify them.
The relation between these variables is: hT = 2 * hT2 = 4 * hT4.
The variable `ebnf-user-arrow' is only used when `ebnf-arrow-shape' is set to
symbol `user'."
:type '(sexp :tag "User Arrow Shape")
:version "20"
:group 'ebnf-shape)
(defcustom ebnf-syntax 'ebnf
"Specify syntax to be recognized.
Valid values are:
`ebnf' ebnf2ps recognizes the syntax described in ebnf2ps
documentation.
The following variables *ONLY* have effect with this
setting:
`ebnf-terminal-regexp', `ebnf-case-fold-search',
`ebnf-lex-comment-char' and `ebnf-lex-eop-char'.
`abnf' ebnf2ps recognizes the syntax described in the URL:
`https://www.ietf.org/rfc/rfc2234.txt'
(\"Augmented BNF for Syntax Specifications: ABNF\").
`iso-ebnf' ebnf2ps recognizes the syntax described in the URL:
`https://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html'
(\"International Standard of the ISO EBNF Notation\").
The following variables *ONLY* have effect with this
setting:
`ebnf-iso-alternative-p' and `ebnf-iso-normalize-p'.
`yacc' ebnf2ps recognizes the Yacc/Bison syntax.
The following variable *ONLY* has effect with this
setting:
`ebnf-yac-ignore-error-recovery'.
`ebnfx' ebnf2ps recognizes the syntax described in the URL:
`https://www.w3.org/TR/2004/REC-xml-20040204/#sec-notation'
(\"Extensible Markup Language (XML) 1.0 (Third Edition)\")
`dtd' ebnf2ps recognizes the syntax described in the URL:
`https://www.w3.org/TR/2004/REC-xml-20040204/'
(\"Extensible Markup Language (XML) 1.0 (Third Edition)\")
Any other value is treated as `ebnf'."
:type '(radio :tag "Syntax"
(const ebnf) (const abnf) (const iso-ebnf)
(const yacc) (const ebnfx) (const dtd))
:version "20"
:group 'ebnf-syntactic)
(defcustom ebnf-lex-comment-char ?\;
"Specify the line comment character.
It's used only when `ebnf-syntax' is `ebnf'."
:type 'character
:version "20"
:group 'ebnf-syntactic)
(defcustom ebnf-lex-eop-char ?.
"Specify the end of production character.
It's used only when `ebnf-syntax' is `ebnf'."
:type 'character
:version "20"
:group 'ebnf-syntactic)
(defcustom ebnf-terminal-regexp nil
"Specify how it's a terminal name.
If it's nil, the terminal name must be enclosed by `\"'.
If it's a string, it should be a regexp that it'll be used to determine a
terminal name; terminal name may also be enclosed by `\"'.
It's used only when `ebnf-syntax' is `ebnf'."
:type '(radio :tag "Terminal Name"
(const nil) regexp)
:version "20"
:group 'ebnf-syntactic)
(defcustom ebnf-case-fold-search nil
"Non-nil means ignore case on matching.
It's only used when `ebnf-terminal-regexp' is non-nil and when `ebnf-syntax' is
`ebnf'."
:type 'boolean
:version "20"
:group 'ebnf-syntactic)
(defcustom ebnf-iso-alternative-p nil
"Non-nil means use alternative ISO EBNF.
It's only used when `ebnf-syntax' is `iso-ebnf'.
This variable affects the following symbol set:
STANDARD ALTERNATIVE
| ==> / or !
[ ==> (/
] ==> /)
{ ==> (:
} ==> :)
; ==> ."
:type 'boolean
:version "20"
:group 'ebnf-syntactic)
(defcustom ebnf-iso-normalize-p nil
"Non-nil means normalize ISO EBNF syntax names.
Normalize a name means that several contiguous spaces inside name become a
single space, so \"A B C\" is normalized to \"A B C\".
It's only used when `ebnf-syntax' is `iso-ebnf'."
:type 'boolean
:version "20"
:group 'ebnf-syntactic)
(defcustom ebnf-file-suffix-regexp "\\.[Bb][Nn][Ff]\\'"
"Specify file name suffix that contains EBNF.
See `ebnf-eps-directory' command."
:type 'regexp
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-eps-prefix "ebnf--"
"Specify EPS prefix file name.
See `ebnf-eps-buffer' and `ebnf-eps-region' commands."
:type 'string
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-eps-header-font '(11 Helvetica "Black" "White" bold)
"Specify EPS header font.
See documentation for `ebnf-production-font'.
See `ebnf-eps-buffer' and `ebnf-eps-region' commands."
:type '(list :tag "EPS Header Font"
(number :tag "Font Size")
(symbol :tag "Font Name")
(choice :tag "Foreground Color"
(string :tag "Name")
(other :tag "Default" nil))
(choice :tag "Background Color"
(string :tag "Name")
(other :tag "Default" nil))
(repeat :tag "Font Attributes" :inline t
(choice (const bold) (const italic)
(const underline) (const strikeout)
(const overline) (const shadow)
(const box) (const outline))))
:version "22"
:group 'ebnf2ps)
(defcustom ebnf-eps-header nil
"Specify EPS header.
The value should be a string, a symbol or nil.
String is inserted unchanged.
For symbol bounded to a function, the function is called and should return a
string. For symbol bounded to a value, the value should be a string.
If symbol is unbounded, it is silently ignored.
Empty string or nil mean that no header will be generated.
Note that when the header action comment (;H in EBNF syntax) is specified, the
string in the header action comment is processed and, if it returns a non-empty
string, it's used to generate the header. The header action comment accepts
the following formats:
%% prints a % character.
%H prints the `ebnf-eps-header' value.
%F prints the `ebnf-eps-footer' (which see) value.
Any other format is ignored, that is, if, for example, it's used %s then %s
characters are stripped out from the header. If header action comment is an
empty string, no header is generated until a non-empty header is specified or
`ebnf-eps-header' has a non-empty string value."
:type '(repeat (choice :menu-tag "EPS Header"
:tag "EPS Header"
string symbol (const :tag "No Header" nil )))
:version "22"
:group 'ebnf2ps)
(defcustom ebnf-eps-footer-font '(7 Helvetica "Black" "White" bold)
"Specify EPS footer font.
See documentation for `ebnf-production-font'.
See `ebnf-eps-buffer' and `ebnf-eps-region' commands."
:type '(list :tag "EPS Footer Font"
(number :tag "Font Size")
(symbol :tag "Font Name")
(choice :tag "Foreground Color"
(string :tag "Name")
(other :tag "Default" nil))
(choice :tag "Background Color"
(string :tag "Name")
(other :tag "Default" nil))
(repeat :tag "Font Attributes" :inline t
(choice (const bold) (const italic)
(const underline) (const strikeout)
(const overline) (const shadow)
(const box) (const outline))))
:version "22"
:group 'ebnf2ps)
(defcustom ebnf-eps-footer nil
"Specify EPS footer.
The value should be a string, a symbol or nil.
String is inserted unchanged.
For symbol bounded to a function, the function is called and should return a
string. For symbol bounded to a value, the value should be a string.
If symbol is unbounded, it is silently ignored.
Empty string or nil mean that no footer will be generated.
Note that when the footer action comment (;F in EBNF syntax) is specified, the
string in the footer action comment is processed and, if it returns a non-empty
string, it's used to generate the footer. The footer action comment accepts
the following formats:
%% prints a % character.
%H prints the `ebnf-eps-header' (which see) value.
%F prints the `ebnf-eps-footer' value.
Any other format is ignored, that is, if, for example, it's used %s then %s
characters are stripped out from the footer. If footer action comment is an
empty string, no footer is generated until a non-empty footer is specified or
`ebnf-eps-footer' has a non-empty string value."
:type '(repeat (choice :menu-tag "EPS Footer"
:tag "EPS Footer"
string symbol (const :tag "No Footer" nil )))
:version "22"
:group 'ebnf2ps)
(defcustom ebnf-entry-percentage 0.5 ; middle
"Specify entry height on alternatives.
It must be a float between 0.0 (top) and 1.0 (bottom)."
:type 'number
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-default-width 0.6
"Additional border width over default terminal, non-terminal or special."
:type 'number
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-color-p t
"Non-nil means use color."
:type 'boolean
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-line-width 1.0
"Specify flow line width."
:type 'number
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-line-color "Black"
"Specify flow line color."
:type 'string
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-arrow-extra-width
(if (eq ebnf-arrow-shape 'none)
0.0
(* (sqrt 5.0) 0.65 ebnf-line-width))
"Specify extra width for arrow shape drawing.
The extra width is used to avoid that the arrowhead and the terminal border
overlap. It depends on `ebnf-arrow-shape' and `ebnf-line-width'."
:type 'number
:version "22"
:group 'ebnf-shape)
(defcustom ebnf-arrow-scale 1.0
"Specify the arrow scale.
Values lower than 1.0, shrink the arrow.
Values greater than 1.0, expand the arrow."
:type 'number
:version "22"
:group 'ebnf-shape)
(defcustom ebnf-debug-ps nil
"Non-nil means to generate PostScript debug procedures.
It is intended to help PostScript programmers in debugging."
:type 'boolean
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-use-float-format t
"Non-nil means use `%f' float format.
The advantage of using float format is that ebnf2ps generates a little short
PostScript file.
If it occurs the error message:
Invalid format operation %f
when executing ebnf2ps, set `ebnf-use-float-format' to nil."
:type 'boolean
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-stop-on-error nil
"Non-nil means signal error and stop. Otherwise, signal error and continue."
:type 'boolean
:version "20"
:group 'ebnf2ps)
(defcustom ebnf-yac-ignore-error-recovery nil
"Non-nil means ignore error recovery.
It's only used when `ebnf-syntax' is `yacc'."
:type 'boolean
:version "20"
:group 'ebnf-syntactic)
(defcustom ebnf-ignore-empty-rule nil
"Non-nil means ignore empty rules.
It's interesting to set this variable if your Yacc/Bison grammar has a lot of
middle action rule."
:type 'boolean
:version "20"
:group 'ebnf-optimization)
(defcustom ebnf-optimize nil
"Non-nil means optimize syntactic chart of rules.
The following optimizations are done:
left recursion:
1. A = B | A C. ==> A = B {C}*.
2. A = B | A B. ==> A = {B}+.
3. A = | A B. ==> A = {B}*.
4. A = B | A C B. ==> A = {B || C}+.
5. A = B | D | A C | A E. ==> A = ( B | D ) { C | E }*.
optional:
6. A = B | . ==> A = [B].
7. A = | B . ==> A = [B].
factorization:
8. A = B C | B D. ==> A = B (C | D).
9. A = C B | D B. ==> A = (C | D) B.
10. A = B C E | B D E. ==> A = B (C | D) E.
The above optimizations are specially useful when `ebnf-syntax' is `yacc'."
:type 'boolean
:version "20"
:group 'ebnf-optimization)
(defcustom ebnf-log nil
"Non-nil means generate log messages.
The log messages are generated into the buffer *Ebnf2ps Log*.
These messages are intended to help debugging ebnf2ps."
:type 'boolean
:version "22"
:group 'ebnf2ps)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To make this file smaller, some commands go in a separate file.
;; But autoload them here to make the separation invisible.
;; Autoload is here to avoid compilation gripes.
(autoload 'ebnf-eliminate-empty-rules "ebnf-otz"
"Eliminate empty rules.")
(autoload 'ebnf-optimize "ebnf-otz"
"Syntactic chart optimizer.")
(autoload 'ebnf-otz-initialize "ebnf-otz"
"Initialize optimizer.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Customization
;;;###autoload
(defun ebnf-customize ()
"Customization for ebnf group."
(interactive)
(customize-group 'ebnf2ps))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User commands
;;;###autoload
(defun ebnf-print-directory (&optional directory)
"Generate and print a PostScript syntactic chart image of DIRECTORY.
If DIRECTORY is nil, it's used `default-directory'.
The files in DIRECTORY that matches `ebnf-file-suffix-regexp' (which see) are
processed.
See also `ebnf-print-buffer'."
(interactive
(list (read-directory-name "Directory containing EBNF files (print): "
nil default-directory)))
(ebnf-log-header "(ebnf-print-directory %S)" directory)
(ebnf-directory 'ebnf-print-buffer directory))
;;;###autoload
(defun ebnf-print-file (file &optional do-not-kill-buffer-when-done)
"Generate and print a PostScript syntactic chart image of the file FILE.
If optional arg DO-NOT-KILL-BUFFER-WHEN-DONE is non-nil, the buffer isn't
killed after process termination.
See also `ebnf-print-buffer'."
(interactive "fEBNF file to generate PostScript and print from: ")
(ebnf-log-header "(ebnf-print-file %S %S)" file do-not-kill-buffer-when-done)
(ebnf-file 'ebnf-print-buffer file do-not-kill-buffer-when-done))
;;;###autoload
(defun ebnf-print-buffer (&optional filename)
"Generate and print a PostScript syntactic chart image of the buffer.
When called with a numeric prefix argument (\\[universal-argument]), prompts the user for
the name of a file to save the PostScript image in, instead of sending
it to the printer.
More specifically, the FILENAME argument is treated as follows: if it
is nil, send the image to the printer. If FILENAME is a string, save
the PostScript image in a file with that name. If FILENAME is a
number, prompt the user for the name of the file to save in."
(interactive (list (ps-print-preprint current-prefix-arg)))
(ebnf-log-header "(ebnf-print-buffer %S)" filename)
(cl-letf (((symbol-function 'ps-output-string)
;; Make non-ASCII work (sort of).
(lambda (string)
(ps-output t (and string
(encode-coding-string string 'iso-8859-1))))))
(ebnf-print-region (point-min) (point-max) filename)))
;;;###autoload
(defun ebnf-print-region (from to &optional filename)
"Generate and print a PostScript syntactic chart image of the region.
Like `ebnf-print-buffer', but prints just the current region."
(interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
(ebnf-log-header "(ebnf-print-region %S %S %S)" from to filename)
(run-hooks 'ebnf-hook)
(or (ebnf-spool-region from to)
(ps-do-despool filename)))
;;;###autoload
(defun ebnf-spool-directory (&optional directory)
"Generate and spool a PostScript syntactic chart image of DIRECTORY.
If DIRECTORY is nil, it's used `default-directory'.
The files in DIRECTORY that matches `ebnf-file-suffix-regexp' (which see) are
processed.
See also `ebnf-spool-buffer'."
(interactive
(list (read-directory-name "Directory containing EBNF files (spool): "
nil default-directory)))
(ebnf-log-header "(ebnf-spool-directory %S)" directory)
(ebnf-directory 'ebnf-spool-buffer directory))
;;;###autoload
(defun ebnf-spool-file (file &optional do-not-kill-buffer-when-done)
"Generate and spool a PostScript syntactic chart image of the file FILE.
If optional arg DO-NOT-KILL-BUFFER-WHEN-DONE is non-nil, the buffer isn't
killed after process termination.
See also `ebnf-spool-buffer'."
(interactive "fEBNF file to generate PostScript and spool from: ")
(ebnf-log-header "(ebnf-spool-file %S %S)" file do-not-kill-buffer-when-done)
(ebnf-file 'ebnf-spool-buffer file do-not-kill-buffer-when-done))
;;;###autoload
(defun ebnf-spool-buffer ()
"Generate and spool a PostScript syntactic chart image of the buffer.
Like `ebnf-print-buffer' except that the PostScript image is saved in a
local buffer to be sent to the printer later.
Use the command `ebnf-despool' to send the spooled images to the printer."
(interactive)
(ebnf-log-header "(ebnf-spool-buffer)")
(ebnf-spool-region (point-min) (point-max)))
;;;###autoload
(defun ebnf-spool-region (from to)
"Generate a PostScript syntactic chart image of the region and spool locally.
Like `ebnf-spool-buffer', but spools just the current region.
Use the command `ebnf-despool' to send the spooled images to the printer."
(interactive "r")
(ebnf-log-header "(ebnf-spool-region %S)" from to)
(ebnf-generate-region from to 'ebnf-generate))
;;;###autoload
(defun ebnf-eps-directory (&optional directory)
"Generate EPS files from EBNF files in DIRECTORY.
If DIRECTORY is nil, it's used `default-directory'.
The files in DIRECTORY that matches `ebnf-file-suffix-regexp' (which see) are
processed.
See also `ebnf-eps-buffer'."
(interactive
(list (read-directory-name "Directory containing EBNF files (EPS): "
nil default-directory)))
(ebnf-log-header "(ebnf-eps-directory %S)" directory)
(ebnf-directory 'ebnf-eps-buffer directory))
;;;###autoload
(defun ebnf-eps-file (file &optional do-not-kill-buffer-when-done)
"Generate an EPS file from EBNF file FILE.
If optional arg DO-NOT-KILL-BUFFER-WHEN-DONE is non-nil, the buffer isn't
killed after EPS generation.
See also `ebnf-eps-buffer'."
(interactive "fEBNF file to generate EPS file from: ")
(ebnf-log-header "(ebnf-eps-file %S %S)" file do-not-kill-buffer-when-done)
(ebnf-file 'ebnf-eps-buffer file do-not-kill-buffer-when-done))
;;;###autoload
(defun ebnf-eps-buffer ()
"Generate a PostScript syntactic chart image of the buffer in an EPS file.
Generate an EPS file for each production in the buffer.
The EPS file name has the following form:
<PREFIX><PRODUCTION>.eps
<PREFIX> is given by variable `ebnf-eps-prefix'.
The default value is \"ebnf--\".
<PRODUCTION> is the production name.
Some characters in the production file name are replaced to
produce a valid file name. For example, the production name
\"A/B + C\" is modified to produce \"A_B_+_C\", and the EPS
file name used in this case will be \"ebnf--A_B_+_C.eps\".
WARNING: This function does *NOT* ask any confirmation to override existing
files."
(interactive)
(ebnf-log-header "(ebnf-eps-buffer)")
(ebnf-eps-region (point-min) (point-max)))
(defvar ebnf-eps-executing)
;;;###autoload
(defun ebnf-eps-region (from to)
"Generate a PostScript syntactic chart image of the region in an EPS file.
Generate an EPS file for each production in the region.
The EPS file name has the following form:
<PREFIX><PRODUCTION>.eps
<PREFIX> is given by variable `ebnf-eps-prefix'.
The default value is \"ebnf--\".
<PRODUCTION> is the production name.
Some characters in the production file name are replaced to
produce a valid file name. For example, the production name
\"A/B + C\" is modified to produce \"A_B_+_C\", and the EPS
file name used in this case will be \"ebnf--A_B_+_C.eps\".
WARNING: This function does *NOT* ask any confirmation to override existing
files."
(interactive "r")
(ebnf-log-header "(ebnf-eps-region %S %S)" from to)
(let ((ebnf-eps-executing t))
(ebnf-generate-region from to 'ebnf-generate-eps)))
;;;###autoload
(defalias 'ebnf-despool #'ps-despool)
;;;###autoload
(defun ebnf-syntax-directory (&optional directory)
"Do a syntactic analysis of the files in DIRECTORY.
If DIRECTORY is nil, use `default-directory'.
Only the files in DIRECTORY that match `ebnf-file-suffix-regexp' (which see)
are processed.
See also `ebnf-syntax-buffer'."
(interactive
(list (read-directory-name "Directory containing EBNF files (syntax): "
nil default-directory)))
(ebnf-log-header "(ebnf-syntax-directory %S)" directory)
(ebnf-directory 'ebnf-syntax-buffer directory))
;;;###autoload
(defun ebnf-syntax-file (file &optional do-not-kill-buffer-when-done)
"Do a syntactic analysis of the named FILE.
If optional arg DO-NOT-KILL-BUFFER-WHEN-DONE is non-nil, the buffer isn't
killed after syntax checking.
See also `ebnf-syntax-buffer'."
(interactive "fEBNF file to check syntax: ")
(ebnf-log-header "(ebnf-syntax-file %S %S)" file do-not-kill-buffer-when-done)
(ebnf-file 'ebnf-syntax-buffer file do-not-kill-buffer-when-done))
;;;###autoload
(defun ebnf-syntax-buffer ()
"Do a syntactic analysis of the current buffer."
(interactive)
(ebnf-log-header "(ebnf-syntax-buffer)")
(ebnf-syntax-region (point-min) (point-max)))
;;;###autoload
(defun ebnf-syntax-region (from to)
"Do a syntactic analysis of a region."
(interactive "r")
(ebnf-log-header "(ebnf-syntax-region %S %S)" from to)
(ebnf-generate-region from to nil))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utilities
;;;###autoload
(defun ebnf-setup ()
"Return the current ebnf2ps setup."
(format
"
;;; Emacs version %S
\(setq ebnf-special-show-delimiter %S
ebnf-special-font %s
ebnf-special-shape %s
ebnf-special-shadow %S
ebnf-special-border-width %S
ebnf-special-border-color %S
ebnf-except-font %s
ebnf-except-shape %s
ebnf-except-shadow %S
ebnf-except-border-width %S
ebnf-except-border-color %S
ebnf-repeat-font %s
ebnf-repeat-shape %s
ebnf-repeat-shadow %S
ebnf-repeat-border-width %S
ebnf-repeat-border-color %S
ebnf-terminal-regexp %S
ebnf-case-fold-search %S
ebnf-terminal-font %s
ebnf-terminal-shape %s
ebnf-terminal-shadow %S
ebnf-terminal-border-width %S
ebnf-terminal-border-color %S
ebnf-non-terminal-font %s
ebnf-non-terminal-shape %s
ebnf-non-terminal-shadow %S
ebnf-non-terminal-border-width %S
ebnf-non-terminal-border-color %S
ebnf-production-name-p %S
ebnf-sort-production %s
ebnf-production-font %s
ebnf-arrow-shape %s
ebnf-chart-shape %s
ebnf-user-arrow %s
ebnf-horizontal-orientation %S
ebnf-horizontal-max-height %S
ebnf-production-horizontal-space %S
ebnf-production-vertical-space %S
ebnf-justify-sequence %s
ebnf-lex-comment-char ?\\%03o
ebnf-lex-eop-char ?\\%03o
ebnf-syntax %s
ebnf-iso-alternative-p %S
ebnf-iso-normalize-p %S
ebnf-file-suffix-regexp %S
ebnf-eps-prefix %S
ebnf-eps-header-font %s
ebnf-eps-header %s
ebnf-eps-footer-font %s
ebnf-eps-footer %s
ebnf-entry-percentage %S
ebnf-color-p %S
ebnf-line-width %S
ebnf-line-color %S
ebnf-arrow-extra-width %S
ebnf-arrow-scale %S
ebnf-debug-ps %S
ebnf-use-float-format %S
ebnf-stop-on-error %S
ebnf-yac-ignore-error-recovery %S
ebnf-ignore-empty-rule %S
ebnf-optimize %S
ebnf-log %S)
;;; ebnf2ps.el - end of settings
"
emacs-version
ebnf-special-show-delimiter
(ps-print-quote ebnf-special-font)
(ps-print-quote ebnf-special-shape)
ebnf-special-shadow
ebnf-special-border-width
ebnf-special-border-color
(ps-print-quote ebnf-except-font)
(ps-print-quote ebnf-except-shape)
ebnf-except-shadow
ebnf-except-border-width
ebnf-except-border-color
(ps-print-quote ebnf-repeat-font)
(ps-print-quote ebnf-repeat-shape)
ebnf-repeat-shadow
ebnf-repeat-border-width
ebnf-repeat-border-color
ebnf-terminal-regexp
ebnf-case-fold-search
(ps-print-quote ebnf-terminal-font)
(ps-print-quote ebnf-terminal-shape)
ebnf-terminal-shadow
ebnf-terminal-border-width
ebnf-terminal-border-color
(ps-print-quote ebnf-non-terminal-font)
(ps-print-quote ebnf-non-terminal-shape)
ebnf-non-terminal-shadow
ebnf-non-terminal-border-width
ebnf-non-terminal-border-color
ebnf-production-name-p
(ps-print-quote ebnf-sort-production)
(ps-print-quote ebnf-production-font)
(ps-print-quote ebnf-arrow-shape)
(ps-print-quote ebnf-chart-shape)
(ps-print-quote ebnf-user-arrow)
ebnf-horizontal-orientation
ebnf-horizontal-max-height
ebnf-production-horizontal-space
ebnf-production-vertical-space
(ps-print-quote ebnf-justify-sequence)
ebnf-lex-comment-char
ebnf-lex-eop-char
(ps-print-quote ebnf-syntax)
ebnf-iso-alternative-p
ebnf-iso-normalize-p
ebnf-file-suffix-regexp
ebnf-eps-prefix
(ps-print-quote ebnf-eps-header-font)
(ps-print-quote ebnf-eps-header)
(ps-print-quote ebnf-eps-footer-font)
(ps-print-quote ebnf-eps-footer)
ebnf-entry-percentage
ebnf-color-p
ebnf-line-width
ebnf-line-color
ebnf-arrow-extra-width
ebnf-arrow-scale
ebnf-debug-ps
ebnf-use-float-format
ebnf-stop-on-error
ebnf-yac-ignore-error-recovery
ebnf-ignore-empty-rule
ebnf-optimize
ebnf-log))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Style variables
(defvar ebnf-stack-style nil
"Stack of styles.
Used in functions `ebnf-reset-style', `ebnf-push-style' and
`ebnf-pop-style'.")
(defvar ebnf-current-style 'default
"Used in functions `ebnf-apply-style' and `ebnf-push-style'.")
(defconst ebnf-style-custom-list
'(ebnf-special-show-delimiter
ebnf-special-font
ebnf-special-shape
ebnf-special-shadow
ebnf-special-border-width
ebnf-special-border-color
ebnf-except-font
ebnf-except-shape
ebnf-except-shadow
ebnf-except-border-width
ebnf-except-border-color
ebnf-repeat-font
ebnf-repeat-shape
ebnf-repeat-shadow
ebnf-repeat-border-width
ebnf-repeat-border-color
ebnf-terminal-regexp
ebnf-case-fold-search
ebnf-terminal-font
ebnf-terminal-shape
ebnf-terminal-shadow
ebnf-terminal-border-width
ebnf-terminal-border-color
ebnf-non-terminal-font
ebnf-non-terminal-shape
ebnf-non-terminal-shadow
ebnf-non-terminal-border-width
ebnf-non-terminal-border-color
ebnf-production-name-p
ebnf-sort-production
ebnf-production-font
ebnf-arrow-shape
ebnf-chart-shape
ebnf-user-arrow
ebnf-horizontal-orientation
ebnf-horizontal-max-height
ebnf-production-horizontal-space
ebnf-production-vertical-space
ebnf-justify-sequence
ebnf-lex-comment-char
ebnf-lex-eop-char
ebnf-syntax
ebnf-iso-alternative-p
ebnf-iso-normalize-p
ebnf-file-suffix-regexp
ebnf-eps-prefix
ebnf-eps-header-font
ebnf-eps-header
ebnf-eps-footer-font
ebnf-eps-footer
ebnf-entry-percentage
ebnf-color-p
ebnf-line-width
ebnf-line-color
ebnf-debug-ps
ebnf-use-float-format
ebnf-stop-on-error
ebnf-yac-ignore-error-recovery
ebnf-ignore-empty-rule
ebnf-optimize)
"List of valid symbol custom variable.")
(defvar ebnf-style-database
'(;; EBNF default
(default
nil
(ebnf-special-show-delimiter . t)
(ebnf-special-font . '(7 Courier "Black" "Gray95" bold italic))
(ebnf-special-shape . 'bevel)
(ebnf-special-shadow . nil)
(ebnf-special-border-width . 0.5)
(ebnf-special-border-color . "Black")
(ebnf-except-font . '(7 Courier "Black" "Gray90" bold italic))
(ebnf-except-shape . 'bevel)
(ebnf-except-shadow . nil)
(ebnf-except-border-width . 0.25)
(ebnf-except-border-color . "Black")
(ebnf-repeat-font . '(7 Courier "Black" "Gray85" bold italic))
(ebnf-repeat-shape . 'bevel)
(ebnf-repeat-shadow . nil)
(ebnf-repeat-border-width . 0.0)
(ebnf-repeat-border-color . "Black")
(ebnf-terminal-regexp . nil)
(ebnf-case-fold-search . nil)
(ebnf-terminal-font . '(7 Courier "Black" "White"))
(ebnf-terminal-shape . 'miter)
(ebnf-terminal-shadow . nil)
(ebnf-terminal-border-width . 1.0)
(ebnf-terminal-border-color . "Black")
(ebnf-non-terminal-font . '(7 Helvetica "Black" "White"))
(ebnf-non-terminal-shape . 'round)
(ebnf-non-terminal-shadow . nil)
(ebnf-non-terminal-border-width . 1.0)
(ebnf-non-terminal-border-color . "Black")
(ebnf-production-name-p . t)
(ebnf-sort-production . nil)
(ebnf-production-font . '(10 Helvetica "Black" "White" bold))
(ebnf-arrow-shape . 'hollow)
(ebnf-chart-shape . 'round)
(ebnf-user-arrow . nil)
(ebnf-horizontal-orientation . nil)
(ebnf-horizontal-max-height . nil)
(ebnf-production-horizontal-space . 0.0)
(ebnf-production-vertical-space . 0.0)
(ebnf-justify-sequence . 'center)
(ebnf-lex-comment-char . ?\;)
(ebnf-lex-eop-char . ?.)
(ebnf-syntax . 'ebnf)
(ebnf-iso-alternative-p . nil)
(ebnf-iso-normalize-p . nil)
(ebnf-file-suffix-regexp . "\\.[Bb][Nn][Ff]\\'")
(ebnf-eps-prefix . "ebnf--")
(ebnf-eps-header-font . '(11 Helvetica "Black" "White" bold))
(ebnf-eps-header . nil)
(ebnf-eps-footer-font . '(7 Helvetica "Black" "White" bold))
(ebnf-eps-footer . nil)
(ebnf-entry-percentage . 0.5)
(ebnf-color-p . t)
(ebnf-line-width . 1.0)
(ebnf-line-color . "Black")
(ebnf-debug-ps . nil)
(ebnf-use-float-format . t)
(ebnf-stop-on-error . nil)
(ebnf-yac-ignore-error-recovery . nil)
(ebnf-ignore-empty-rule . nil)
(ebnf-optimize . nil))
;; Happy EBNF default
(happy
default
(ebnf-justify-sequence . 'left)
(ebnf-lex-comment-char . ?\#)
(ebnf-lex-eop-char . ?\;))
;; ABNF default
(abnf
default
(ebnf-syntax . 'abnf))
;; ISO EBNF default
(iso-ebnf
default
(ebnf-syntax . 'iso-ebnf))
;; Yacc/Bison default
(yacc
default
(ebnf-syntax . 'yacc))
;; ebnfx default
(ebnfx
default
(ebnf-syntax . 'ebnfx))
;; dtd default
(dtd
default
(ebnf-syntax . 'dtd))
)
"Style database.
Each element has the following form:
(NAME INHERITS (VAR . VALUE)...)
Where:
NAME is a symbol name style.
INHERITS is a symbol name style from which the current style inherits
the context. If INHERITS is nil, then there is no inheritance.
This is a simple inheritance of style: if you declare that
style A inherits from style B, all settings of B are applied
first, and then the settings of A are applied. This is useful
when you wish to modify some aspects of an existing style, but
at the same time wish to keep it unmodified.
VAR is a valid ebnf2ps symbol custom variable.
See `ebnf-style-custom-list' for valid symbol variables.
VALUE is a sexp which will be evaluated to set the value of VAR.
Don't forget to quote symbols and constant lists.
See `default' style for an example.
Don't use this variable directly. Use functions `ebnf-insert-style',
`ebnf-delete-style' and `ebnf-merge-style'.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Style commands
;;;###autoload
(defun ebnf-find-style (name)
"Return style definition if NAME is already defined; otherwise, return nil.
See `ebnf-style-database' documentation."
(interactive "SStyle name: ")
(assoc name ebnf-style-database))
;;;###autoload
(defun ebnf-insert-style (name inherits &rest values)
"Insert a new style NAME with inheritance INHERITS and values VALUES.
See `ebnf-style-database' documentation."
(interactive "SStyle name: \nSStyle inherits from: \nXStyle values: ")
(and (assoc name ebnf-style-database)
(error "Style name already exists: %s" name))
(or (assoc inherits ebnf-style-database)
(error "Style inheritance name doesn't exist: %s" inherits))
(setq ebnf-style-database
(cons (cons name (cons inherits (ebnf-check-style-values values)))
ebnf-style-database)))
;;;###autoload
(defun ebnf-delete-style (name)
"Delete style NAME.
See `ebnf-style-database' documentation."
(interactive "SDelete style name: ")
(or (assoc name ebnf-style-database)
(error "Style name doesn't exist: %s" name))
(let ((db ebnf-style-database))
(while db
(and (eq (nth 1 (car db)) name)
(error "Style name `%s' is inherited by `%s' style"
name (nth 0 (car db))))
(setq db (cdr db))))
(setq ebnf-style-database (assq-delete-all name ebnf-style-database)))
;;;###autoload
(defun ebnf-merge-style (name &rest values)
"Merge values of style NAME with style VALUES.
See `ebnf-style-database' documentation."
(interactive "SStyle name: \nXStyle values: ")
(let ((style (or (assoc name ebnf-style-database)
(error "Style name doesn't exist: %s" name)))
(merge (ebnf-check-style-values values))
val elt new check)
;; modify value of existing variables
(setq val (nthcdr 2 style))
(while merge
(setq check (car merge)
merge (cdr merge)
elt (assoc (car check) val))
(if elt
(setcdr elt (cdr check))
(setq new (cons check new))))
;; insert new variables
(nconc style (nreverse new))))
;;;###autoload
(defun ebnf-apply-style (style)
"Set STYLE as the current style.
Returns the old style symbol.
See `ebnf-style-database' documentation."
(interactive "SApply style: ")
(prog1
ebnf-current-style
(and (ebnf-apply-style1 style)
(setq ebnf-current-style style))))
;;;###autoload
(defun ebnf-reset-style (&optional style)
"Reset current style.
Returns the old style symbol.
See `ebnf-style-database' documentation."
(interactive "SReset style: ")
(setq ebnf-stack-style nil)
(ebnf-apply-style (or style 'default)))
;;;###autoload
(defun ebnf-push-style (&optional style)
"Push the current style onto a stack and set STYLE as the current style.
Returns the old style symbol.
See also `ebnf-pop-style'.
See `ebnf-style-database' documentation."
(interactive "SPush style: ")
(prog1
ebnf-current-style
(setq ebnf-stack-style (cons ebnf-current-style ebnf-stack-style))
(and style
(ebnf-apply-style style))))
;;;###autoload
(defun ebnf-pop-style ()
"Pop a style from the stack of pushed styles and set it as the current style.
Returns the old style symbol.
See also `ebnf-push-style'.
See `ebnf-style-database' documentation."
(interactive)
(prog1
(ebnf-apply-style (car ebnf-stack-style))
(setq ebnf-stack-style (cdr ebnf-stack-style))))
(defun ebnf-apply-style1 (style)
(let ((value (cdr (assoc style ebnf-style-database))))
(prog1
value
(and (car value) (ebnf-apply-style1 (car value)))
(while (setq value (cdr value))
(set (caar value) (eval (cdar value) t))))))
(defun ebnf-check-style-values (values)
(let (style)
(while values
(and (memq (caar values) ebnf-style-custom-list)
(setq style (cons (car values) style)))
(setq values (cdr values)))
(nreverse style)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal variables
(defvar ebnf-eps-buffer-name " *EPS*")
(defvar ebnf-parser-func nil)
(defvar ebnf-eps-executing nil)
(defvar ebnf-eps-header-comment nil)
(defvar ebnf-eps-footer-comment nil)
(defvar-local ebnf-eps-upper-x 0.0)
(defvar-local ebnf-eps-upper-y 0.0)
(defvar-local ebnf-eps-prod-width 0.0)
(defvar-local ebnf-eps-max-height 0.0)
(defvar-local ebnf-eps-max-width 0.0)
(defvar ebnf-eps-context nil
"List of EPS file name during parsing.
See section \"Actions in Comments\" in ebnf2ps documentation.")
(defvar ebnf-eps-file-alist nil
"Alist associating file name with EPS header and footer.
Each element has the following form:
(EPS-FILENAME HEADER FOOTER)
EPS-FILENAME is the EPS file name.
HEADER is the header string or nil.
FOOTER is the footer string or nil.
It's generated during parsing and used during EPS generation.
See `ebnf-eps-context' and section \"Actions in Comments\" in ebnf2ps
documentation.")
(defvar ebnf-eps-production-list nil
"Alist associating production name with EPS file name list.
Each element has the following form:
(PRODUCTION EPS-FILENAME...)
PRODUCTION is the production name.
EPS-FILENAME is the EPS file name.
This is generated during parsing and used during EPS generation.
See `ebnf-eps-context' and section \"Actions in Comments\" in ebnf2ps
documentation.")
(defconst ebnf-arrow-shape-alist
'((none . 0)
(semi-up . 1)
(semi-down . 2)
(simple . 3)
(transparent . 4)
(hollow . 5)
(full . 6)
(semi-up-hollow . 7)
(semi-up-full . 8)
(semi-down-hollow . 9)
(semi-down-full . 10)
(user . 11))
"Alist associating values for `ebnf-arrow-shape'.
See documentation for `ebnf-arrow-shape'.")
(defconst ebnf-terminal-shape-alist
'((miter . 0)
(round . 1)
(bevel . 2))
"Alist associating values from `ebnf-terminal-shape' to a bit vector.
See documentation for `ebnf-terminal-shape', `ebnf-non-terminal-shape' and
`ebnf-chart-shape'.")
(defvar ebnf-limit nil)
(defvar ebnf-action nil)
(defvar ebnf-action-list nil)
(defvar ebnf-default-p nil)
(defvar ebnf-font-height-P 0)
(defvar ebnf-font-height-T 0)
(defvar ebnf-font-height-NT 0)
(defvar ebnf-font-height-S 0)
(defvar ebnf-font-height-E 0)
(defvar ebnf-font-height-R 0)
(defvar ebnf-font-width-P 0)
(defvar ebnf-font-width-T 0)
(defvar ebnf-font-width-NT 0)
(defvar ebnf-font-width-S 0)
(defvar ebnf-font-width-E 0)
(defvar ebnf-font-width-R 0)
(defvar ebnf-space-T 0)
(defvar ebnf-space-NT 0)
(defvar ebnf-space-S 0)
(defvar ebnf-space-E 0)
(defvar ebnf-space-R 0)
(defvar ebnf-basic-width-extra 0)
(defvar ebnf-basic-width 0)
(defvar ebnf-basic-height 0)
(defvar ebnf-basic-empty-height 0)
(defvar ebnf-vertical-space 0)
(defvar ebnf-horizontal-space 0)
(defvar ebnf-settings nil)
(defvar ebnf-fonts-required nil)
(defconst ebnf-debug
"
% === begin EBNF procedures to help debugging
% Mark visually current point: string debug
/debug
{/-s- exch def
currentpoint
gsave -s- show grestore
gsave
20 20 rlineto
0 -40 rlineto
-40 40 rlineto
0 -40 rlineto
20 20 rlineto
stroke
grestore
moveto
}def
% Show number value: number string debug-number
/debug-number
{gsave
20 0 rmoveto show ([) show 60 string cvs show (]) show
grestore
}def
% === end EBNF procedures to help debugging
"
"This is intended to help debugging PostScript programming.")
(defconst ebnf-prologue
"
% === begin EBNF engine
% --- Basic Definitions
/fS F
/SpaceS FontHeight 0.5 mul def
/HeightS FontHeight FontHeight add def
/fE F
/SpaceE FontHeight 0.5 mul def
/HeightE FontHeight FontHeight add def
/fR F
/SpaceR FontHeight 0.5 mul def
/HeightR FontHeight FontHeight add def
/fT F
/SpaceT FontHeight 0.5 mul def
/HeightT FontHeight FontHeight add def
/fNT F
/SpaceNT FontHeight 0.5 mul def
/HeightNT FontHeight FontHeight add def
/T HeightT HeightNT add 0.5 mul def
/hT T 0.5 mul def
/hT2 hT 0.5 mul ArrowScale mul def
/hT4 hT 0.25 mul ArrowScale mul def
/Er 0.1 def % Error factor
/c{currentpoint}bind def
/xyi{/xi c /yi exch def def}bind def
/xyo{/xo c /yo exch def def}bind def
/xyp{/xp c /yp exch def def}bind def
/xyt{/xt c /yt exch def def}bind def
% vertical movement: x y height vm
/vm{add moveto}bind def
% horizontal movement: x y width hm
/hm{3 -1 roll exch add exch moveto}bind def
% set color: [R G B] SetRGB
/SetRGB{aload pop setrgbcolor}bind def
% filling gray area: gray-scale FillGray
/FillGray{gsave setgray fill grestore}bind def
% filling color area: [R G B] FillRGB
/FillRGB{gsave SetRGB fill grestore}bind def
/Stroke{LineWidth setlinewidth LineColor SetRGB stroke}bind def
/StrokeShape{borderwidth setlinewidth bordercolor SetRGB stroke}bind def
/Gstroke{gsave Stroke grestore}bind def
% Empty Line: width EL
/EL{0 rlineto Gstroke}bind def
% --- Arrows
/Down{hT2 neg hT4 neg rlineto}bind def
/Arrow
{hT2 neg hT4 rmoveto
hT2 hT4 neg rlineto
Down
}bind def
/ArrowPath{c newpath moveto Arrow closepath}bind def
/UpPath
{c newpath moveto
hT2 neg 0 rmoveto
0 hT4 rlineto
hT2 hT4 neg rlineto
closepath
}bind def
/DownPath
{c newpath moveto
hT2 neg 0 rmoveto
0 hT4 neg rlineto
hT2 hT4 rlineto
closepath
}bind def
%>Right Arrow: RA
% \\
% *---+
% /
/RA-vector
[{} % 0 - none
{hT2 neg hT4 rlineto} % 1 - semi-up
{Down} % 2 - semi-down
{Arrow} % 3 - simple
{Gstroke ArrowPath} % 4 - transparent
{Gstroke ArrowPath 1 FillGray} % 5 - hollow
{Gstroke ArrowPath LineColor FillRGB} % 6 - full
{Gstroke UpPath 1 FillGray} % 7 - semi-up-hollow
{Gstroke UpPath LineColor FillRGB} % 8 - semi-up-full
{Gstroke DownPath 1 FillGray} % 9 - semi-down-hollow
{Gstroke DownPath LineColor FillRGB} % 10 - semi-down-full
{Gstroke gsave UserArrow grestore} % 11 - user
]def
/RA
{hT 0 rlineto
c
RA-vector ArrowShape get exec
Gstroke
moveto
ExtraWidth 0 rmoveto
}def
% rotation DrawArrow
/DrawArrow
{gsave
0 0 translate
rotate
RA
c
grestore
rmoveto
}def
%>Left Arrow: LA
% /
% +---*
% \\
/LA{180 DrawArrow}def
%>Up Arrow: UA
% +
% /|\\
% |
% *
/UA{90 DrawArrow}def
%>Down Arrow: DA
% *
% |
% \\|/
% +
/DA{270 DrawArrow}def
% --- Corners
%>corner Right Descendant: height arrow corner_RD
% _ | arrow
% / height > 0 | 0 - none
% | | 1 - right
% * ---------- | 2 - left
% | | 3 - vertical
% \\ height < 0 |
% - |
/cRD0-vector
[% 0 - none
{0 h rlineto
hT 0 rlineto}
% 1 - right
{0 h rlineto
RA}
% 2 - left
{hT 0 rmoveto xyi
LA
0 h neg rlineto
xi yi moveto}
% 3 - vertical
{hT h rmoveto xyi
hT neg 0 rlineto
h 0 gt{DA}{UA}ifelse
xi yi moveto}
]def
/cRD-vector
[{cRD0-vector arrow get exec} % 0 - miter
{0 0 0 h hT h rcurveto} % 1 - rounded
{hT h rlineto} % 2 - bevel
]def
/corner_RD
{/arrow exch def /h exch def
cRD-vector ChartShape get exec
Gstroke
}def
%>corner Right Ascendant: height arrow corner_RA
% | arrow
% | height > 0 | 0 - none
% / | 1 - right
% *- ---------- | 2 - left
% \\ | 3 - vertical
% | height < 0 |
% |
/cRA0-vector
[% 0 - none
{hT 0 rlineto
0 h rlineto}
% 1 - right
{RA
0 h rlineto}
% 2 - left
{hT h rmoveto xyi
0 h neg rlineto
LA
xi yi moveto}
% 3 - vertical
{hT h rmoveto xyi
h 0 gt{DA}{UA}ifelse
hT neg 0 rlineto
xi yi moveto}
]def
/cRA-vector
[{cRA0-vector arrow get exec} % 0 - miter
{0 0 hT 0 hT h rcurveto} % 1 - rounded
{hT h rlineto} % 2 - bevel
]def
/corner_RA
{/arrow exch def /h exch def
cRA-vector ChartShape get exec
Gstroke
}def
%>corner Left Descendant: height arrow corner_LD
% _ | arrow
% \\ height > 0 | 0 - none
% | | 1 - right
% * ---------- | 2 - left
% | | 3 - vertical
% / height < 0 |
% - |
/cLD0-vector
[% 0 - none
{0 h rlineto
hT neg 0 rlineto}
% 1 - right
{hT neg h rmoveto xyi
RA
0 h neg rlineto
xi yi moveto}
% 2 - left
{0 h rlineto
LA}
% 3 - vertical
{hT neg h rmoveto xyi
hT 0 rlineto
h 0 gt{DA}{UA}ifelse
xi yi moveto}
]def
/cLD-vector
[{cLD0-vector arrow get exec} % 0 - miter
{0 0 0 h hT neg h rcurveto} % 1 - rounded
{hT neg h rlineto} % 2 - bevel
]def
/corner_LD
{/arrow exch def /h exch def
cLD-vector ChartShape get exec
Gstroke
}def
%>corner Left Ascendant: height arrow corner_LA
% | arrow
% | height > 0 | 0 - none
% \\ | 1 - right
% -* ---------- | 2 - left
% / | 3 - vertical
% | height < 0 |
% |
/cLA0-vector
[% 0 - none
{hT neg 0 rlineto
0 h rlineto}
% 1 - right
{hT neg h rmoveto xyi
0 h neg rlineto
RA
xi yi moveto}
% 2 - left
{LA
0 h rlineto}
% 3 - vertical
{hT neg h rmoveto xyi
h 0 gt{DA}{UA}ifelse
hT 0 rlineto
xi yi moveto}
]def
/cLA-vector
[{cLA0-vector arrow get exec} % 0 - miter
{0 0 hT neg 0 hT neg h rcurveto} % 1 - rounded
{hT neg h rlineto} % 2 - bevel
]def
/corner_LA
{/arrow exch def /h exch def
cLA-vector ChartShape get exec
Gstroke
}def
% --- Flow Stuff
% height prepare-height |- line_height corner_height corner_height
/prepare-height
{dup 0 gt
{T sub hT}
{T add hT neg}ifelse
dup
}def
%>Left Alternative: height LAlt
% _
% /
% | height > 0
% |
% /
% *- ----------
% \\
% |
% | height < 0
% \\
% -
/LAlt
{dup 0 eq
{T exch rlineto}
{dup abs T lt
{0.5 mul dup
1 corner_RA
0 corner_RD}
{prepare-height
1 corner_RA
exch 0 exch rlineto
0 corner_RD
}ifelse
}ifelse
}def
%>Left Loop: height LLoop
% _
% /
% | height > 0
% |
% \\
% -* ----------
% /
% |
% | height < 0
% \\
% -
/LLoop
{prepare-height
3 corner_LA
exch 0 exch rlineto
0 corner_RD
}def
%>Right Alternative: height RAlt
% _
% \\
% | height > 0
% |
% \\
% -* ----------
% /
% |
% | height < 0
% /
% -
/RAlt
{dup 0 eq
{T neg exch rlineto}
{dup abs T lt
{0.5 mul dup
1 corner_LA
0 corner_LD}
{prepare-height
1 corner_LA
exch 0 exch rlineto
0 corner_LD
}ifelse
}ifelse
}def
%>Right Loop: height RLoop
% _
% \\
% | height > 0
% |
% /
% *- ----------
% \\
% |
% | height < 0
% /
% -
/RLoop
{prepare-height
1 corner_RA
exch 0 exch rlineto
0 corner_LD
}def
% --- Terminal, Non-terminal and Special Basics
% string width prepare-width |- string
/prepare-width
{/width exch def
dup stringwidth pop space add space add width exch sub ExtraWidth sub 0.5 mul
/w exch def
}def
% string width begin-right
/begin-right
{xyo
prepare-width
w hT sub EL
RA
}def
% end-right
/end-right
{xo width add Er add yo moveto
w Er add neg EL
xo yo moveto
}def
% string width begin-left
/begin-left
{xyo
prepare-width
w EL
}def
% end-left
/end-left
{xo width add Er add yo moveto
hT w sub Er add EL
LA
xo yo moveto
}def
/ShapePath-vector
[% 0 - miter
{xx yy moveto
xx YY lineto
XX YY lineto
XX yy lineto}
% 1 - rounded
{/half YY yy sub 0.5 mul abs def
xx half add YY moveto
0 0 half neg 0 half neg half neg rcurveto
0 0 0 half neg half half neg rcurveto
XX xx sub abs half sub half sub 0 rlineto
0 0 half 0 half half rcurveto
0 0 0 half half neg half rcurveto}
% 2 - bevel
{/quarter YY yy sub 0.25 mul abs def
xx quarter add YY moveto
quarter neg quarter neg rlineto
0 quarter quarter add neg rlineto
quarter quarter neg rlineto
XX xx sub abs quarter sub quarter sub 0 rlineto
quarter quarter rlineto
0 quarter quarter add rlineto
quarter neg quarter rlineto}
]def
/doShapePath
{newpath
ShapePath-vector shape get exec
closepath
}def
/doShapeShadow
{gsave
Xshadow Xshadow add Xshadow add
Yshadow Yshadow add Yshadow add translate
doShapePath
0.9 FillGray
grestore
}def
/doShape
{gsave
doShapePath
shapecolor FillRGB
StrokeShape
grestore
}def
% string SBound |- string
/SBound
{/xx c dup /yy exch def
FontHeight add /YY exch def def
dup stringwidth pop xx add /XX exch def
Effect 8 and 0 ne
{/yy yy YShadow add def
/XX XX XShadow add def
}if
}def
% string SBox
/SBox
{gsave
c space sub moveto
SBound
/XX XX space add space add def
/YY YY space add def
/yy yy space sub def
shadow{doShapeShadow}if
doShape
space Descent abs rmoveto
foreground SetRGB S
grestore
}def
% --- Terminal
% TeRminal: string TR
/TR
{/Effect EffectT def
/shape ShapeT def
/shapecolor BackgroundT def
/borderwidth BorderWidthT def
/bordercolor BorderColorT def
/foreground ForegroundT def
/shadow ShadowT def
SBox
}def
%>Right Terminal: string width RT |- x y
/RT
{xyt
/fT F
/space SpaceT def
begin-right
TR
end-right
xt yt
}def
%>Left Terminal: string width LT |- x y
/LT
{xyt
/fT F
/space SpaceT def
begin-left
TR
end-left
xt yt
}def
%>Right Terminal Default: string width RTD |- x y
/RTD
{/-save- BorderWidthT def
/BorderWidthT BorderWidthT DefaultWidth add def
RT
/BorderWidthT -save- def
}def
%>Left Terminal Default: string width LTD |- x y
/LTD
{/-save- BorderWidthT def
/BorderWidthT BorderWidthT DefaultWidth add def
LT
/BorderWidthT -save- def
}def
% --- Non-Terminal
% Non-Terminal: string NT
/NT
{/Effect EffectNT def
/shape ShapeNT def
/shapecolor BackgroundNT def
/borderwidth BorderWidthNT def
/bordercolor BorderColorNT def
/foreground ForegroundNT def
/shadow ShadowNT def
SBox
}def
%>Right Non-Terminal: string width RNT |- x y
/RNT
{xyt
/fNT F
/space SpaceNT def
begin-right
NT
end-right
xt yt
}def
%>Left Non-Terminal: string width LNT |- x y
/LNT
{xyt
/fNT F
/space SpaceNT def
begin-left
NT
end-left
xt yt
}def
%>Right Non-Terminal Default: string width RNTD |- x y
/RNTD
{/-save- BorderWidthNT def
/BorderWidthNT BorderWidthNT DefaultWidth add def
RNT
/BorderWidthNT -save- def
}def
%>Left Non-Terminal Default: string width LNTD |- x y
/LNTD
{/-save- BorderWidthNT def
/BorderWidthNT BorderWidthNT DefaultWidth add def
LNT
/BorderWidthNT -save- def
}def
% --- Special
% SPecial: string SP
/SP
{/Effect EffectS def
/shape ShapeS def
/shapecolor BackgroundS def
/borderwidth BorderWidthS def
/bordercolor BorderColorS def
/foreground ForegroundS def
/shadow ShadowS def
SBox
}def
%>Right SPecial: string width RSP |- x y
/RSP
{xyt
/fS F
/space SpaceS def
begin-right
SP
end-right
xt yt
}def
%>Left SPecial: string width LSP |- x y
/LSP
{xyt
/fS F
/space SpaceS def
begin-left
SP
end-left
xt yt
}def
%>Right SPecial Default: string width RSPD |- x y
/RSPD
{/-save- BorderWidthS def
/BorderWidthS BorderWidthS DefaultWidth add def
RSP
/BorderWidthS -save- def
}def
%>Left SPecial Default: string width LSPD |- x y
/LSPD
{/-save- BorderWidthS def
/BorderWidthS BorderWidthS DefaultWidth add def
LSP
/BorderWidthS -save- def
}def
% --- Repeat and Except basics
/begin-direction
{/w width rwidth sub 0.5 mul def
width 0 rmoveto}def
/end-direction
{gsave
/xx c entry add /YY exch def def
/yy YY height sub def
/XX xx rwidth add def
shadow{doShapeShadow}if
doShape
grestore
}def
/right-direction
{begin-direction
w neg EL
xt yt moveto
w hT sub EL RA
end-direction
}def
/left-direction
{begin-direction
hT w sub EL LA
xt yt moveto
w EL
end-direction
}def
% --- Repeat
% entry height width rwidth begin-repeat
/begin-repeat
{/rwidth exch def
/width exch def
/height exch def
/entry exch def
/fR F
/space SpaceR def
/Effect EffectR def
/shape ShapeR def
/shapecolor BackgroundR def
/borderwidth BorderWidthR def
/bordercolor BorderColorR def
/foreground ForegroundR def
/shadow ShadowR def
xyt
}def
% string end-repeat |- x y
/end-repeat
{gsave
space Descent rmoveto
foreground SetRGB S
c Descent sub
grestore
exch space add exch moveto
xt yt
}def
%>Right RePeat: string entry height width rwidth RRP |- x y
/RRP{begin-repeat right-direction end-repeat}def
%>Left RePeat: string entry height width rwidth LRP |- x y
/LRP{begin-repeat left-direction end-repeat}def
% --- Except
% entry height width rwidth begin-except
/begin-except
{/rwidth exch def
/width exch def
/height exch def
/entry exch def
/fE F
/space SpaceE def
/Effect EffectE def
/shape ShapeE def
/shapecolor BackgroundE def
/borderwidth BorderWidthE def
/bordercolor BorderColorE def
/foreground ForegroundE def
/shadow ShadowE def
xyt
}def
% x-width end-except |- x y
/end-except
{gsave
space space add add Descent rmoveto
(-) foreground SetRGB S
grestore
space 0 rmoveto
xt yt
}def
%>Right EXcept: x-width entry height width rwidth REX |- x y
/REX{begin-except right-direction end-except}def
%>Left EXcept: x-width entry height width rwidth LEX |- x y
/LEX{begin-except left-direction end-except}def
% --- Sequence
%>Beginning Of Sequence: BOS |- x y
/BOS{currentpoint}bind def
%>End Of Sequence: x y x1 y1 EOS |- x y
/EOS{pop pop}bind def
% --- Production
%>Beginning Of Production: string width height BOP |- y x
/BOP
{xyp
neg yp add /yw exch def
xp add T sub /xw exch def
dup length 0 gt % empty string ==> no production name
{/Effect EffectP def
/fP F ForegroundP SetRGB BackgroundP aload pop true BG S
/Effect 0 def
( :) S false BG}{pop}ifelse
xw yw moveto
hT EL RA
xp yw moveto
T EL
yp xp
}def
%>End Of Production: y x delta EOP
/EOPH{add exch moveto}bind def % horizontal
/EOPV{exch pop sub 0 exch moveto}bind def % vertical
% --- Empty Alternative
%>Empty Alternative: width EA |- x y
/EA
{gsave
Er add 0 rlineto
Stroke
grestore
c
}def
% --- Alternative
%>AlTernative: h1 h2 ... hn n width AT |- x y
/AT
{xyo xo add /xw exch def
xw yo moveto
Er EL
{xw yo moveto
dup RAlt
xo yo moveto
LAlt}repeat
xo yo
}def
% --- Optional
%>OPtional: height width OP |- x y
/OP
{xyo
T sub /ow exch def
ow Er sub 0 rmoveto
T Er add EL
neg dup RAlt
ow T sub neg EL
xo yo moveto
LAlt
xo yo moveto
T EL
xo yo
}def
% --- List Flow
%>One or More: height width OM |- x y
/OM
{xyo
/ow exch def
ow Er add 0 rmoveto
T Er add neg EL
dup RLoop
xo T add yo moveto
LLoop
xo yo moveto
T EL
xo yo
}def
%>Zero or More: h2 h1 width ZM |- x y
/ZM
{xyo
Er add EL
Er neg 0 rmoveto
dup RAlt
exch dup RLoop
xo yo moveto
exch dup LAlt
exch LLoop
yo add xo T add exch moveto
xo yo
}def
% === end EBNF engine
"
"EBNF PostScript prologue.")
(defconst ebnf-eps-prologue
"
/#ebnf2ps#dict 230 dict def
#ebnf2ps#dict begin
% Initialize variables to avoid name-conflicting with document variables.
% This is the case when using `bind' operator.
/-fillp- 0 def /h 0 def
/-ox- 0 def /half 0 def
/-oy- 0 def /height 0 def
/-save- 0 def /ow 0 def
/Ascent 0 def /quarter 0 def
/Descent 0 def /rXX 0 def
/Effect 0 def /rYY 0 def
/FontHeight 0 def /rwidth 0 def
/LineThickness 0 def /rxx 0 def
/OverlinePosition 0 def /ryy 0 def
/SpaceBackground 0 def /shadow 0 def
/StrikeoutPosition 0 def /shape 0 def
/UnderlinePosition 0 def /shapecolor 0 def
/XBox 0 def /space 0 def
/XX 0 def /st 1 string def
/Xshadow 0 def /w 0 def
/YBox 0 def /width 0 def
/YY 0 def /xi 0 def
/Yshadow 0 def /xo 0 def
/arrow 0 def /xp 0 def
/bg false def /xt 0 def
/bgcolor 0 def /xw 0 def
/bordercolor 0 def /xx 0 def
/borderwidth 0 def /yi 0 def
/dd 0 def /yo 0 def
/entry 0 def /yp 0 def
/foreground 0 def /yt 0 def
/yy 0 def
% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4:
/ISOLatin1Encoding where
{pop}
{% -- The ISO Latin-1 encoding vector isn't known, so define it.
% -- The first half is the same as the standard encoding,
% -- except for minus instead of hyphen at code 055.
/ISOLatin1Encoding
StandardEncoding 0 45 getinterval aload pop
/minus
StandardEncoding 46 82 getinterval aload pop
%*** NOTE: the following are missing in the Adobe documentation,
%*** but appear in the displayed table:
%*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240.
% 0200 (128)
/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
/dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
/dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron
% 0240 (160)
/space /exclamdown /cent /sterling
/currency /yen /brokenbar /section
/dieresis /copyright /ordfeminine /guillemotleft
/logicalnot /hyphen /registered /macron
/degree /plusminus /twosuperior /threesuperior
/acute /mu /paragraph /periodcentered
/cedilla /onesuperior /ordmasculine /guillemotright
/onequarter /onehalf /threequarters /questiondown
% 0300 (192)
/Agrave /Aacute /Acircumflex /Atilde
/Adieresis /Aring /AE /Ccedilla
/Egrave /Eacute /Ecircumflex /Edieresis
/Igrave /Iacute /Icircumflex /Idieresis
/Eth /Ntilde /Ograve /Oacute
/Ocircumflex /Otilde /Odieresis /multiply
/Oslash /Ugrave /Uacute /Ucircumflex
/Udieresis /Yacute /Thorn /germandbls
% 0340 (224)
/agrave /aacute /acircumflex /atilde
/adieresis /aring /ae /ccedilla
/egrave /eacute /ecircumflex /edieresis
/igrave /iacute /icircumflex /idieresis
/eth /ntilde /ograve /oacute
/ocircumflex /otilde /odieresis /divide
/oslash /ugrave /uacute /ucircumflex
/udieresis /yacute /thorn /ydieresis
256 packedarray def
}ifelse
/reencodeFontISO %def
{dup
length 12 add dict % Make a new font (a new dict the same size
% as the old one) with room for our new symbols.
begin % Make the new font the current dictionary.
{1 index /FID ne
{def}{pop pop}ifelse
}forall % Copy each of the symbols from the old dictionary
% to the new one except for the font ID.
currentdict /FontType get 0 ne
{/Encoding ISOLatin1Encoding def}if % Override the encoding with
% the ISOLatin1 encoding.
% Use the font's bounding box to determine the ascent, descent,
% and overall height; don't forget that these values have to be
% transformed using the font's matrix.
% ^ (x2 y2)
% | |
% | v
% | +----+ - -
% | | | ^
% | | | | Ascent (usually > 0)
% | | | |
% (0 0) -> +--+----+-------->
% | | |
% | | v Descent (usually < 0)
% (x1 y1) --> +----+ - -
currentdict /FontType get 0 ne
{/FontBBox load aload pop % -- x1 y1 x2 y2
FontMatrix transform /Ascent exch def pop
FontMatrix transform /Descent exch def pop}
{/PrimaryFont FDepVector 0 get def
PrimaryFont /FontBBox get aload pop
PrimaryFont /FontMatrix get transform /Ascent exch def pop
PrimaryFont /FontMatrix get transform /Descent exch def pop
}ifelse
/FontHeight Ascent Descent sub def % use `sub' because descent < 0
% Define these in case they're not in the FontInfo
% (also, here they're easier to get to).
/UnderlinePosition Descent 0.70 mul def
/OverlinePosition Descent UnderlinePosition sub Ascent add def
/StrikeoutPosition Ascent 0.30 mul def
/LineThickness FontHeight 0.05 mul def
/Xshadow FontHeight 0.08 mul def
/Yshadow FontHeight -0.09 mul def
/SpaceBackground Descent neg UnderlinePosition add def
/XBox Descent neg def
/YBox LineThickness 0.7 mul def
currentdict % Leave the new font on the stack
end % Stop using the font as the current dictionary
definefont % Put the font into the font dictionary
pop % Discard the returned font
}bind def
% Font definition
/DefFont{findfont exch scalefont reencodeFontISO}def
% Font selection
/F
{findfont
dup /Ascent get /Ascent exch def
dup /Descent get /Descent exch def
dup /FontHeight get /FontHeight exch def
dup /UnderlinePosition get /UnderlinePosition exch def
dup /OverlinePosition get /OverlinePosition exch def
dup /StrikeoutPosition get /StrikeoutPosition exch def
dup /LineThickness get /LineThickness exch def
dup /Xshadow get /Xshadow exch def
dup /Yshadow get /Yshadow exch def
dup /SpaceBackground get /SpaceBackground exch def
dup /XBox get /XBox exch def
dup /YBox get /YBox exch def
setfont
}def
/BG
{dup /bg exch def
{mark 4 1 roll ]}
{[ 1.0 1.0 1.0 ]}
ifelse
/bgcolor exch def
}def
% stack: --
/FillBgColor{bgcolor aload pop setrgbcolor fill}bind def
% stack: fill-or-not lower-x lower-y upper-x upper-y |- --
/doRect
{/rYY exch def
/rXX exch def
/ryy exch def
/rxx exch def
gsave
newpath
rXX rYY moveto
rxx rYY lineto
rxx ryy lineto
rXX ryy lineto
closepath
% top of stack: fill-or-not
{FillBgColor}
{LineThickness setlinewidth stroke}
ifelse
grestore
}bind def
% stack: string fill-or-not |- --
/doOutline
{/-fillp- exch def
/-ox- currentpoint /-oy- exch def def
gsave
LineThickness setlinewidth
{st 0 3 -1 roll put
st dup true charpath
-fillp- {gsave FillBgColor grestore}if
stroke stringwidth
-oy- add /-oy- exch def
-ox- add /-ox- exch def
-ox- -oy- moveto
}forall
grestore
-ox- -oy- moveto
}bind def
% stack: fill-or-not delta |- --
/doBox
{/dd exch def
xx XBox sub dd sub yy YBox sub dd sub
XX XBox add dd add YY YBox add dd add
doRect
}bind def
% stack: string |- --
/doShadow
{gsave
Xshadow Yshadow rmoveto
false doOutline
grestore
}bind def
% stack: position |- --
/Hline
{currentpoint exch pop add dup
gsave
newpath
xx exch moveto
XX exch lineto
closepath
LineThickness setlinewidth stroke
grestore
}bind def
% stack: string |- --
% effect: 1 - underline 2 - strikeout 4 - overline
% 8 - shadow 16 - box 32 - outline
/S
{/xx currentpoint dup Descent add /yy exch def
Ascent add /YY exch def def
dup stringwidth pop xx add /XX exch def
Effect 8 and 0 ne
{/yy yy Yshadow add def
/XX XX Xshadow add def
}if
bg
{true
Effect 16 and 0 ne
{SpaceBackground doBox}
{xx yy XX YY doRect}
ifelse
}if % background
Effect 16 and 0 ne{false 0 doBox}if % box
Effect 8 and 0 ne{dup doShadow}if % shadow
Effect 32 and 0 ne
{true doOutline} % outline
{show} % normal text
ifelse
Effect 1 and 0 ne{UnderlinePosition Hline}if % underline
Effect 2 and 0 ne{StrikeoutPosition Hline}if % strikeout
Effect 4 and 0 ne{OverlinePosition Hline}if % overline
}bind def
"
"EBNF EPS prologue.")
(defconst ebnf-eps-begin
"
end
% x y #ebnf2ps#begin
/#ebnf2ps#begin
{#ebnf2ps#dict begin /#ebnf2ps#save save def
moveto false BG 0.0 0.0 0.0 setrgbcolor}def
/#ebnf2ps#end{showpage #ebnf2ps#save restore end}def
%%EndProlog
"
"EBNF EPS begin.")
(defconst ebnf-eps-end
"#ebnf2ps#end
%%EOF
"
"EBNF EPS end.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Header & Footer
(defun ebnf-eps-header-footer (value)
;; evaluate header/footer value
;; return a string or nil
(let ((tmp (if (symbolp value)
(cond ((fboundp value) (funcall value))
((boundp value) (symbol-value value))
(t nil))
value)))
(and (stringp tmp) tmp)))
(defun ebnf-eps-header ()
;; evaluate header value
(ebnf-eps-header-footer ebnf-eps-header))
(defun ebnf-eps-footer ()
;; evaluate footer value
(ebnf-eps-header-footer ebnf-eps-footer))
;; hacked from `ps-output-string-prim' (ps-print.el)
(defun ebnf-eps-string (string)
(let* ((str string)
(len (length str))
(index 0)
(new "(") ; insert start-string delimiter
start special)
;; Find and quote special characters as necessary for PS
;; This skips everything except control chars, non-ASCII chars,
;; (, ), \, and DEL.
(while (setq start (string-match "[[:cntrl:][:nonascii:]\177()\\]"
str index))
(setq special (aref str start)
new (concat new
(substring str index start)
(if (and (<= 0 special) (<= special 255))
(aref ps-string-escape-codes special)
;; insert hexadecimal representation if character
;; code is out of range
(format "\\%04X" special)))
index (1+ start)))
(concat new
(and (< index len)
(substring str index len))
")"))) ; insert end-string delimiter
(defun ebnf-eps-header-footer-comment (str)
;; parse header/footer comment string
(let ((len (1- (length str)))
(index 0)
new start fmt)
(while (setq start (string-search "%" str index))
(setq fmt (if (< start len) (aref str (1+ start)) ?\?)
new (concat new
(substring str index start)
(cond ((= fmt ?%) "%")
((= fmt ?H) (ebnf-eps-header))
((= fmt ?F) (ebnf-eps-footer))
(t nil)
))
index (+ start 2)))
(ebnf-eps-string (concat new
(and (<= index len)
(substring str index (1+ len)))))))
(defun ebnf-eps-header-footer-p (value)
;; return t if value is non-nil and is not an empty string
(not (or (null value)
(and (stringp value) (string= value "")))))
(defun ebnf-eps-header-comment (str)
;; set header comment if header is on
(when (ebnf-eps-header-footer-p ebnf-eps-header)
(setq ebnf-eps-header-comment (ebnf-eps-header-footer-comment str))))
(defun ebnf-eps-footer-comment (str)
;; set footer comment if footer is on
(when (ebnf-eps-header-footer-p ebnf-eps-footer)
(setq ebnf-eps-footer-comment (ebnf-eps-header-footer-comment str))))
(defun ebnf-eps-header-footer-file (filename)
;; associate header and footer with a filename
(let ((filehf (assoc filename ebnf-eps-file-alist))
(header (or ebnf-eps-header-comment (ebnf-eps-header)))
(footer (or ebnf-eps-footer-comment (ebnf-eps-footer))))
(if (null filehf)
(setq ebnf-eps-file-alist (cons (list filename header footer)
ebnf-eps-file-alist))
(setcar (nthcdr 1 filehf) header)
(setcar (nthcdr 2 filehf) footer))))
(defun ebnf-eps-header-footer-set (filename)
;; set header and footer from a filename
(let ((header-footer (assoc filename ebnf-eps-file-alist)))
(setq ebnf-eps-header-comment (nth 1 header-footer)
ebnf-eps-footer-comment (nth 2 header-footer))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Formatting
(defvar ebnf-format-float "%1.3f")
(defun ebnf-format-float (&rest floats)
(mapconcat
(lambda (float)
(format ebnf-format-float float))
floats
" "))
(defun ebnf-format-color (format-str color default)
(let* ((the-color (or color default))
(rgb (ps-color-scale the-color)))
(format format-str
(concat "["
(ebnf-format-float (nth 0 rgb) (nth 1 rgb) (nth 2 rgb))
"]")
the-color)))
(defvar ebnf-message-float "%3.2f")
(defsubst ebnf-message-float (format-str value)
(message format-str
(format ebnf-message-float value)))
(defvar ebnf-total 0)
(defvar ebnf-nprod 0)
(defsubst ebnf-message-info (msg)
(message "%s...%3d%%"
msg
(round (/ (* (setq ebnf-nprod (1+ ebnf-nprod)) 100.0) ebnf-total))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Macros
(defmacro ebnf-node-kind (vec &optional value)
(if value
`(aset ,vec 0 ,value)
`(aref ,vec 0)))
(defmacro ebnf-node-width-func (node width)
`(funcall (aref ,node 1) ,node ,width))
(defmacro ebnf-node-dimension-func (node &optional value)
(if value
`(aset ,node 2 ,value)
`(funcall (aref ,node 2) ,node)))
(defmacro ebnf-node-entry (vec &optional value)
(if value
`(aset ,vec 3 ,value)
`(aref ,vec 3)))
(defmacro ebnf-node-height (vec &optional value)
(if value
`(aset ,vec 4 ,value)
`(aref ,vec 4)))
(defmacro ebnf-node-width (vec &optional value)
(if value
`(aset ,vec 5 ,value)
`(aref ,vec 5)))
(defmacro ebnf-node-name (vec)
`(aref ,vec 6))
(defmacro ebnf-node-list (vec &optional value)
(if value
`(aset ,vec 6 ,value)
`(aref ,vec 6)))
(defmacro ebnf-node-default (vec)
`(aref ,vec 7))
(defmacro ebnf-node-production (vec &optional value)
(if value
`(aset ,vec 7 ,value)
`(aref ,vec 7)))
(defmacro ebnf-node-separator (vec &optional value)
(if value
`(aset ,vec 7 ,value)
`(aref ,vec 7)))
(defmacro ebnf-node-action (vec &optional value)
(if value
`(aset ,vec 8 ,value)
`(aref ,vec 8)))
(defmacro ebnf-node-generation (node)
`(funcall (ebnf-node-kind ,node) ,node))
(defmacro ebnf-max-width (prod)
`(max (ebnf-node-width ,prod)
(+ (* (length (ebnf-node-name ,prod))
ebnf-font-width-P)
ebnf-production-horizontal-space)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PostScript generation
(defvar ebnf-tree)
(defun ebnf-generate-eps (tree)
(let* ((ebnf-tree tree)
(ps-color-p (and ebnf-color-p (display-color-p)))
(ps-print-color-scale (if ps-color-p
(float (car (color-values "white")))
1.0))
(ebnf-total (length ebnf-tree))
(ebnf-nprod 0)
(eps-buffer (get-buffer-create ebnf-eps-buffer-name))
ebnf-debug-ps horizontal
prod prod-name prod-width prod-height prod-list file-list)
;; generate EPS file
(unwind-protect
;; redefines `ps-output' and `ps-output-string'
(cl-letf (((symbol-function 'ps-output) #'ebnf-eps-output)
((symbol-function 'ps-output-string) #'ps-output-string-prim))
(save-excursion
(while ebnf-tree
(setq prod (car ebnf-tree)
prod-name (ebnf-node-name prod)
prod-width (ebnf-max-width prod)
prod-height (ebnf-node-height prod)
horizontal (memq (ebnf-node-action prod)
ebnf-action-list))
;; generate production in EPS buffer
(with-current-buffer eps-buffer
(setq ebnf-eps-upper-x 0.0
ebnf-eps-upper-y 0.0
ebnf-eps-max-width prod-width
ebnf-eps-max-height prod-height)
(ebnf-generate-production prod))
(if (setq prod-list (cdr (assoc prod-name
ebnf-eps-production-list)))
;; insert EPS buffer in all buffer associated with production
(ebnf-eps-production-list
prod-list (gv-ref file-list) horizontal
prod-width prod-height eps-buffer)
;; write EPS file for production
(ebnf-eps-finish-and-write eps-buffer
(ebnf-eps-filename prod-name)))
;; prepare for next loop
(with-current-buffer eps-buffer
(erase-buffer))
(setq ebnf-tree (cdr ebnf-tree)))
;; write and kill temporary buffers
(ebnf-eps-write-kill-temp file-list t)
(setq file-list nil)))
;; kill temporary buffers
(kill-buffer eps-buffer)
(ebnf-eps-write-kill-temp file-list nil))
(message " ")))
;; write and kill temporary buffers
(defun ebnf-eps-write-kill-temp (file-list write-p)
(while file-list
(let ((buffer (get-buffer (concat " *" (car file-list) "*"))))
(when buffer
(and write-p
(ebnf-eps-finish-and-write buffer (car file-list)))
(kill-buffer buffer)))
(setq file-list (cdr file-list))))
;; insert EPS buffer in all buffer associated with production
(defun ebnf-eps-production-list (prod-list file-list-ref horizontal
prod-width prod-height eps-buffer)
(while prod-list
(cl-pushnew (car prod-list) (gv-deref file-list-ref) :test #'equal)
(with-current-buffer (get-buffer-create (concat " *" (car prod-list) "*"))
(goto-char (point-max))
(cond
;; first production
((zerop (buffer-size))
(setq ebnf-eps-upper-x 0.0
ebnf-eps-upper-y 0.0
ebnf-eps-max-width prod-width
ebnf-eps-max-height prod-height))
;; horizontal
(horizontal
(ebnf-eop-horizontal ebnf-eps-prod-width)
(setq ebnf-eps-max-width (+ ebnf-eps-max-width
ebnf-production-horizontal-space
prod-width)
ebnf-eps-max-height (max ebnf-eps-max-height prod-height)))
;; vertical
(t
(ebnf-eop-vertical ebnf-eps-max-height)
(setq ebnf-eps-upper-x (max ebnf-eps-upper-x ebnf-eps-max-width)
ebnf-eps-upper-y (if (zerop ebnf-eps-upper-y)
ebnf-eps-max-height
(+ ebnf-eps-upper-y
ebnf-production-vertical-space
ebnf-eps-max-height))
ebnf-eps-max-width prod-width
ebnf-eps-max-height prod-height))
)
(setq ebnf-eps-prod-width prod-width)
(insert-buffer-substring eps-buffer))
(setq prod-list (cdr prod-list))))
(defun ebnf-generate (tree)
(let* ((ebnf-tree tree)
(ps-color-p (and ebnf-color-p (display-color-p)))
(ps-print-color-scale (if ps-color-p
(float (car (color-values "white")))
1.0))
ps-zebra-stripes ps-line-number ps-razzle-dazzle
ps-print-hook
ps-print-begin-sheet-hook
ps-print-begin-page-hook
ps-print-begin-column-hook)
(ps-generate (current-buffer) (point-min) (point-max)
#'ebnf-generate-postscript)))
(defvar ebnf-direction "R")
(defun ebnf-generate-postscript (_from _to)
(ebnf-begin-file)
(if ebnf-horizontal-max-height
(ebnf-generate-with-max-height)
(ebnf-generate-without-max-height))
(message " "))
(defun ebnf-generate-with-max-height ()
(let ((ebnf-total (length ebnf-tree))
(ebnf-nprod 0)
next-line max-height prod the-width)
(while ebnf-tree
;; find next line point
(setq next-line ebnf-tree
prod (car ebnf-tree)
max-height (ebnf-node-height prod))
(ebnf-begin-line prod (ebnf-max-width prod))
(while (and (setq next-line (cdr next-line))
(setq prod (car next-line))
(memq (ebnf-node-action prod) ebnf-action-list)
(setq the-width (ebnf-max-width prod))
(<= the-width ps-width-remaining))
(setq max-height (max max-height (ebnf-node-height prod))
ps-width-remaining (- ps-width-remaining
(+ the-width
ebnf-production-horizontal-space))))
;; generate current line
(ebnf-newline max-height)
(setq prod (car ebnf-tree))
(ebnf-generate-production prod)
(while (not (eq (setq ebnf-tree (cdr ebnf-tree)) next-line))
(ebnf-eop-horizontal (ebnf-max-width prod))
(setq prod (car ebnf-tree))
(ebnf-generate-production prod))
(ebnf-eop-vertical max-height))))
(defun ebnf-generate-without-max-height ()
(let ((ebnf-total (length ebnf-tree))
(ebnf-nprod 0)
max-height prod bef-width cur-width)
(while ebnf-tree
;; generate current line
(setq prod (car ebnf-tree)
max-height (ebnf-node-height prod)
bef-width (ebnf-max-width prod))
(ebnf-begin-line prod bef-width)
(ebnf-generate-production prod)
(while (and (setq ebnf-tree (cdr ebnf-tree))
(setq prod (car ebnf-tree))
(memq (ebnf-node-action prod) ebnf-action-list)
(setq cur-width (ebnf-max-width prod))
(<= cur-width ps-width-remaining)
(<= (ebnf-node-height prod) ps-height-remaining))
(ebnf-eop-horizontal bef-width)
(ebnf-generate-production prod)
(setq bef-width cur-width
max-height (max max-height (ebnf-node-height prod))
ps-width-remaining (- ps-width-remaining
(+ cur-width
ebnf-production-horizontal-space))))
(ebnf-eop-vertical max-height)
;; prepare next line
(ebnf-newline max-height))))
(defun ebnf-begin-line (prod width)
(and (or (eq (ebnf-node-action prod) 'form-feed)
(> (ebnf-node-height prod) ps-height-remaining))
(ebnf-new-page))
(setq ps-width-remaining (- ps-width-remaining
(+ width
ebnf-production-horizontal-space))))
(defun ebnf-newline (height)
(and (> height ps-height-remaining)
(ebnf-new-page))
(setq ps-width-remaining ps-print-width
ps-height-remaining (- ps-height-remaining
(+ height
ebnf-production-vertical-space))))
;; [production width-fun dim-fun entry height width name production action]
(defun ebnf-generate-production (production)
(ebnf-message-info "Generating")
(run-hooks 'ebnf-production-hook)
(ps-output-string (if ebnf-production-name-p
(ebnf-node-name production)
""))
(ps-output " "
(ebnf-format-float
(ebnf-node-width production)
(+ (if ebnf-production-name-p
ebnf-basic-height
0.0)
(ebnf-node-entry (ebnf-node-production production))))
" BOP\n")
(ebnf-node-generation (ebnf-node-production production))
(ps-output "EOS\n"))
;; [alternative width-fun dim-fun entry height width list]
(defun ebnf-generate-alternative (alternative)
(let ((alt (ebnf-node-list alternative))
(entry (ebnf-node-entry alternative))
(nlist 0)
alt-height alt-entry)
(while alt
(ps-output (ebnf-format-float (- entry (ebnf-node-entry (car alt))))
" ")
(setq entry (- entry (ebnf-node-height (car alt)) ebnf-vertical-space)
nlist (1+ nlist)
alt (cdr alt)))
(ps-output (format "%d " nlist)
(ebnf-format-float (ebnf-node-width alternative))
" AT\n")
(setq alt (ebnf-node-list alternative))
(when alt
(ebnf-node-generation (car alt))
(setq alt-height (- (ebnf-node-height (car alt))
(ebnf-node-entry (car alt)))))
(while (setq alt (cdr alt))
(setq alt-entry (ebnf-node-entry (car alt)))
(ebnf-vertical-movement
(- (+ alt-height ebnf-vertical-space alt-entry)))
(ebnf-node-generation (car alt))
(setq alt-height (- (ebnf-node-height (car alt)) alt-entry))))
(ps-output "EOS\n"))
;; [sequence width-fun dim-fun entry height width list]
(defun ebnf-generate-sequence (sequence)
(ps-output "BOS\n")
(let ((seq (ebnf-node-list sequence))
seq-width)
(when seq
(ebnf-node-generation (car seq))
(setq seq-width (ebnf-node-width (car seq))))
(while (setq seq (cdr seq))
(ebnf-horizontal-movement seq-width)
(ebnf-node-generation (car seq))
(setq seq-width (ebnf-node-width (car seq)))))
(ps-output "EOS\n"))
;; [terminal width-fun dim-fun entry height width name]
(defun ebnf-generate-terminal (terminal)
(ebnf-gen-terminal terminal "T"))
;; [non-terminal width-fun dim-fun entry height width name]
(defun ebnf-generate-non-terminal (non-terminal)
(ebnf-gen-terminal non-terminal "NT"))
;; [empty width-fun dim-fun entry height width]
(defun ebnf-generate-empty (empty)
(ebnf-empty-alternative (ebnf-node-width empty)))
;; [optional width-fun dim-fun entry height width element]
(defun ebnf-generate-optional (optional)
(let ((the-optional (ebnf-node-list optional)))
(ps-output (ebnf-format-float
(+ (- (ebnf-node-height the-optional)
(ebnf-node-entry optional))
ebnf-vertical-space)
(ebnf-node-width optional))
" OP\n")
(ebnf-node-generation the-optional)
(ps-output "EOS\n")))
;; [one-or-more width-fun dim-fun entry height width element separator]
(defun ebnf-generate-one-or-more (one-or-more)
(let* ((width (ebnf-node-width one-or-more))
(sep (ebnf-node-separator one-or-more))
(entry (- (ebnf-node-entry one-or-more)
(if sep
(ebnf-node-entry sep)
0))))
(ps-output (ebnf-format-float entry width)
" OM\n")
(ebnf-node-generation (ebnf-node-list one-or-more))
(ebnf-vertical-movement entry)
(if sep
(let ((ebnf-direction "L"))
(ebnf-node-generation sep))
(ebnf-empty-alternative (- width
ebnf-horizontal-space
ebnf-basic-width-extra))))
(ps-output "EOS\n"))
;; [zero-or-more width-fun dim-fun entry height width element separator]
(defun ebnf-generate-zero-or-more (zero-or-more)
(let* ((width (ebnf-node-width zero-or-more))
(node-list (ebnf-node-list zero-or-more))
(list-entry (ebnf-node-entry node-list))
(node-sep (ebnf-node-separator zero-or-more))
(entry (+ list-entry
ebnf-vertical-space
(if node-sep
(- (ebnf-node-height node-sep)
(ebnf-node-entry node-sep))
ebnf-basic-empty-height))))
(ps-output (ebnf-format-float entry
(+ (- (ebnf-node-height node-list)
list-entry)
ebnf-vertical-space)
width)
" ZM\n")
(ebnf-node-generation (ebnf-node-list zero-or-more))
(ebnf-vertical-movement entry)
(if (ebnf-node-separator zero-or-more)
(let ((ebnf-direction "L"))
(ebnf-node-generation (ebnf-node-separator zero-or-more)))
(ebnf-empty-alternative (- width
ebnf-horizontal-space
ebnf-basic-width-extra))))
(ps-output "EOS\n"))
;; [special width-fun dim-fun entry height width name]
(defun ebnf-generate-special (special)
(ebnf-gen-terminal special "SP"))
;; [repeat width-fun dim-fun entry height width times element]
(defun ebnf-generate-repeat (repeat)
(let ((times (ebnf-node-name repeat))
(element (ebnf-node-separator repeat)))
(ps-output-string times)
(ps-output " "
(ebnf-format-float
(ebnf-node-entry repeat)
(ebnf-node-height repeat)
(ebnf-node-width repeat)
(if element
(+ (ebnf-node-width element)
ebnf-space-R ebnf-space-R ebnf-space-R
(* (length times) ebnf-font-width-R))
0.0))
" " ebnf-direction "RP\n")
(and element
(ebnf-node-generation element)))
(ps-output "EOS\n"))
;; [except width-fun dim-fun entry height width element element]
(defun ebnf-generate-except (except)
(let* ((element (ebnf-node-list except))
(exception (ebnf-node-separator except))
(width (ebnf-node-width element)))
(ps-output (ebnf-format-float
width
(ebnf-node-entry except)
(ebnf-node-height except)
(ebnf-node-width except)
(+ width
ebnf-space-E ebnf-space-E ebnf-space-E
ebnf-font-width-E
(if exception
(+ (ebnf-node-width exception) ebnf-space-E)
0.0)))
" " ebnf-direction "EX\n")
(ebnf-node-generation (ebnf-node-list except))
(when exception
(ebnf-horizontal-movement (+ width ebnf-space-E
ebnf-font-width-E ebnf-space-E))
(ebnf-node-generation exception)))
(ps-output "EOS\n"))
(defun ebnf-gen-terminal (node code)
(ps-output-string (ebnf-node-name node))
(ps-output " " (ebnf-format-float (ebnf-node-width node))
" " ebnf-direction code
(if (ebnf-node-default node)
"D\n"
"\n")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal functions
(defun ebnf-directory (fun &optional directory)
"Process files in DIRECTORY applying function FUN on each file.
If DIRECTORY is nil, use `default-directory'.
Only files in DIRECTORY that match `ebnf-file-suffix-regexp' (which see) are
processed."
(let ((files (directory-files (or directory default-directory)
t ebnf-file-suffix-regexp)))
(while files
(set-buffer (find-file-noselect (car files)))
(funcall fun)
(setq buffer-backed-up t) ; Do not back it up.
(save-buffer) ; Just save new version.
(kill-buffer (current-buffer))
(setq files (cdr files)))))
(defun ebnf-file (fun file &optional do-not-kill-buffer-when-done)
"Process the named FILE applying function FUN.
If optional arg DO-NOT-KILL-BUFFER-WHEN-DONE is non-nil, the buffer isn't
killed after process termination."
(set-buffer (find-file-noselect file))
(funcall fun)
(or do-not-kill-buffer-when-done
(kill-buffer (current-buffer))))
(defvar ebnf-map-name
(let ((map (make-vector 256 ?\_)))
(mapc (lambda (char)
(aset map char char))
(concat "#$%&+-.0123456789=?@~"
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"abcdefghijklmnopqrstuvwxyz"))
map))
(defun ebnf-eps-filename (str)
(let* ((len (length str))
(stri 0)
(new (make-string len ?\ )))
(while (< stri len)
(aset new stri (aref ebnf-map-name (aref str stri)))
(setq stri (1+ stri)))
(concat ebnf-eps-prefix new ".eps")))
(defun ebnf-eps-output (&rest args)
(while args
(insert (car args))
(setq args (cdr args))))
(defun ebnf-generate-region (from to gen-func)
(run-hooks 'ebnf-hook)
(let ((ebnf-limit (max from to))
(error-msg "SYNTAX")
the-point)
(save-excursion
(save-restriction
(save-match-data
(condition-case data
(let ((tree (ebnf-parse-and-sort (min from to))))
(when gen-func
(setq error-msg "EMPTY RULES"
tree (ebnf-eliminate-empty-rules tree))
(setq error-msg "OPTIMIZE"
tree (ebnf-optimize tree))
(setq error-msg "DIMENSIONS"
tree (ebnf-dimensions tree))
(setq error-msg "GENERATION")
(funcall gen-func tree))
(setq error-msg nil)) ; here it's ok
;; handler
((quit error)
(ding)
(setq the-point (max (1- (point)) (point-min))
error-msg (concat error-msg ": "
(error-message-string data)
", "
(and (string= error-msg "SYNTAX")
(format "at position %d "
the-point))
(format "in buffer \"%s\"."
(buffer-name)))))))))
(cond
;; error occurred
(error-msg
(goto-char the-point)
(if ebnf-stop-on-error
(error error-msg)
(message "%s" error-msg)))
;; generated output OK
(gen-func
nil)
;; syntax checked OK
(t
(message "EBNF syntactic analysis: NO ERRORS.")))))
(defun ebnf-parse-and-sort (start)
(ebnf-log "(ebnf-parse-and-sort %S)" start)
(ebnf-begin-job)
(let ((tree (funcall ebnf-parser-func start)))
(if ebnf-sort-production
(progn
(message "Sorting...")
(sort tree
(if (eq ebnf-sort-production 'ascending)
'ebnf-sorter-ascending
'ebnf-sorter-descending)))
(nreverse tree))))
(defun ebnf-sorter-ascending (first second)
(string< (ebnf-node-name first)
(ebnf-node-name second)))
(defun ebnf-sorter-descending (first second)
(string< (ebnf-node-name second)
(ebnf-node-name first)))
(defun ebnf-empty-alternative (width)
(ps-output (ebnf-format-float width) " EA\n"))
(defun ebnf-vertical-movement (height)
(ps-output (ebnf-format-float height) " vm\n"))
(defun ebnf-horizontal-movement (width)
(ps-output (ebnf-format-float width) " hm\n"))
(defun ebnf-entry (height)
(* height ebnf-entry-percentage))
(defun ebnf-eop-vertical (height)
(ps-output (ebnf-format-float (+ height ebnf-production-vertical-space))
" EOPV\n\n"))
(defun ebnf-eop-horizontal (width)
(ps-output (ebnf-format-float (+ width ebnf-production-horizontal-space))
" EOPH\n\n"))
(defun ebnf-new-page ()
(when (< ps-height-remaining ps-print-height)
(run-hooks 'ebnf-page-hook)
(ps-next-page)
(ps-output "\n")))
(defsubst ebnf-font-size (font) (nth 0 font))
(defsubst ebnf-font-name (font) (nth 1 font))
(defsubst ebnf-font-foreground (font) (nth 2 font))
(defsubst ebnf-font-background (font) (nth 3 font))
(defsubst ebnf-font-list (font) (nthcdr 4 font))
(defsubst ebnf-font-attributes (font)
(ash (ps-extension-bit (cdr font)) -2))
(defconst ebnf-font-name-select
(vector 'normal 'bold 'italic 'bold-italic))
(defun ebnf-font-name-select (font)
(let* ((font-list (ebnf-font-list font))
(font-index (+ (if (memq 'bold font-list) 1 0)
(if (memq 'italic font-list) 2 0)))
(name (ebnf-font-name font))
(database (cdr (assoc name ps-font-info-database)))
(info-list (or (cdr (assoc 'fonts database))
(error "Invalid font: %s" name))))
(or (cdr (assoc (aref ebnf-font-name-select font-index)
info-list))
(error "Invalid attributes for font %s" name))))
(defun ebnf-font-select (font select)
(let* ((name (ebnf-font-name font))
(database (cdr (assoc name ps-font-info-database)))
(size (cdr (assoc 'size database)))
(base (cdr (assoc select database))))
(if (and size base)
(/ (* (ebnf-font-size font) base)
size)
(error "Invalid font: %s" name))))
(defsubst ebnf-font-width (font)
(ebnf-font-select font 'avg-char-width))
(defsubst ebnf-font-height (font)
(ebnf-font-select font 'line-height))
(defconst ebnf-syntax-alist
;; 0.syntax 1.parser 2.initializer
'((iso-ebnf ebnf-iso-parser ebnf-iso-initialize)
(yacc ebnf-yac-parser ebnf-yac-initialize)
(abnf ebnf-abn-parser ebnf-abn-initialize)
(ebnf ebnf-bnf-parser ebnf-bnf-initialize)
(ebnfx ebnf-ebx-parser ebnf-ebx-initialize)
(dtd ebnf-dtd-parser ebnf-dtd-initialize))
"Alist associating EBNF syntax with a parser and an initializer.")
(defun ebnf-begin-job ()
(ps-printing-region nil nil nil)
(if ebnf-use-float-format
(setq ebnf-format-float "%1.3f"
ebnf-message-float "%3.2f")
(setq ebnf-format-float "%s"
ebnf-message-float "%s"))
(ebnf-otz-initialize)
;; to avoid compilation gripes when calling autoloaded functions
(let ((init (or (assoc ebnf-syntax ebnf-syntax-alist)
(assoc 'ebnf ebnf-syntax-alist))))
(setq ebnf-parser-func (nth 1 init))
(funcall (nth 2 init)))
(and ebnf-terminal-regexp ; ensures that it's a string or nil
(not (stringp ebnf-terminal-regexp))
(setq ebnf-terminal-regexp nil))
(or (and ebnf-eps-prefix ; ensures that it's a string
(stringp ebnf-eps-prefix))
(setq ebnf-eps-prefix "ebnf--"))
(setq ebnf-entry-percentage ; ensures value between 0.0 and 1.0
(min (max ebnf-entry-percentage 0.0) 1.0)
ebnf-action-list (if ebnf-horizontal-orientation
'(nil keep-line)
'(keep-line))
ebnf-settings nil
ebnf-fonts-required nil
ebnf-action nil
ebnf-default-p nil
ebnf-eps-context nil
ebnf-eps-file-alist nil
ebnf-eps-production-list nil
ebnf-eps-header-comment nil
ebnf-eps-footer-comment nil
ebnf-eps-upper-x 0.0
ebnf-eps-upper-y 0.0
ebnf-font-height-P (ebnf-font-height ebnf-production-font)
ebnf-font-height-T (ebnf-font-height ebnf-terminal-font)
ebnf-font-height-NT (ebnf-font-height ebnf-non-terminal-font)
ebnf-font-height-S (ebnf-font-height ebnf-special-font)
ebnf-font-height-E (ebnf-font-height ebnf-except-font)
ebnf-font-height-R (ebnf-font-height ebnf-repeat-font)
ebnf-font-width-P (ebnf-font-width ebnf-production-font)
ebnf-font-width-T (ebnf-font-width ebnf-terminal-font)
ebnf-font-width-NT (ebnf-font-width ebnf-non-terminal-font)
ebnf-font-width-S (ebnf-font-width ebnf-special-font)
ebnf-font-width-E (ebnf-font-width ebnf-except-font)
ebnf-font-width-R (ebnf-font-width ebnf-repeat-font)
ebnf-space-T (* ebnf-font-height-T 0.5)
ebnf-space-NT (* ebnf-font-height-NT 0.5)
ebnf-space-S (* ebnf-font-height-S 0.5)
ebnf-space-E (* ebnf-font-height-E 0.5)
ebnf-space-R (* ebnf-font-height-R 0.5))
(let ((basic (+ ebnf-font-height-T ebnf-font-height-NT)))
(setq ebnf-basic-width (* basic 0.5)
ebnf-horizontal-space (+ basic basic)
ebnf-basic-empty-height (* ebnf-basic-width 0.5)
ebnf-basic-height ebnf-basic-width
ebnf-vertical-space ebnf-basic-width
ebnf-basic-width-extra (- ebnf-basic-width
ebnf-arrow-extra-width
0.1)) ; error factor
;; ensures value is greater than zero
(or (and (numberp ebnf-production-horizontal-space)
(> ebnf-production-horizontal-space 0.0))
(setq ebnf-production-horizontal-space basic))
;; ensures value is greater than zero
(or (and (numberp ebnf-production-vertical-space)
(> ebnf-production-vertical-space 0.0))
(setq ebnf-production-vertical-space basic)))
(ebnf-log "(ebnf-begin-job)")
(ebnf-log " ebnf-arrow-extra-width ............ : %7.3f" ebnf-arrow-extra-width)
(ebnf-log " ebnf-arrow-scale .................. : %7.3f" ebnf-arrow-scale)
(ebnf-log " ebnf-basic-width-extra ............ : %7.3f" ebnf-basic-width-extra)
(ebnf-log " ebnf-basic-width .................. : %7.3f (T)" ebnf-basic-width)
(ebnf-log " ebnf-horizontal-space ............. : %7.3f (4T)" ebnf-horizontal-space)
(ebnf-log " ebnf-basic-empty-height ........... : %7.3f (hT)" ebnf-basic-empty-height)
(ebnf-log " ebnf-basic-height ................. : %7.3f (T)" ebnf-basic-height)
(ebnf-log " ebnf-vertical-space ............... : %7.3f (T)" ebnf-vertical-space)
(ebnf-log " ebnf-production-horizontal-space .. : %7.3f (2T)" ebnf-production-horizontal-space)
(ebnf-log " ebnf-production-vertical-space .... : %7.3f (2T)" ebnf-production-vertical-space))
(defsubst ebnf-shape-value (sym alist)
(or (cdr (assq sym alist)) 0))
(defsubst ebnf-boolean (value)
(if value "true" "false"))
(defun ebnf-begin-file ()
(ps-flush-output)
(with-current-buffer ps-spool-buffer
(goto-char (point-min))
(and (search-forward "%%Creator: " nil t)
(not (search-forward "& ebnf2ps v"
(line-end-position)
t))
(progn
;; insert ebnf settings & engine
(goto-char (point-max))
(search-backward "\n%%EndProlog\n")
(ebnf-insert-ebnf-prologue)
(ps-output "\n")))))
(defun ebnf-eps-finish-and-write (buffer filename)
(when (buffer-modified-p buffer)
(with-current-buffer buffer
(ebnf-eps-header-footer-set filename)
(setq ebnf-eps-upper-x (max ebnf-eps-upper-x ebnf-eps-max-width)
ebnf-eps-upper-y (if (zerop ebnf-eps-upper-y)
ebnf-eps-max-height
(+ ebnf-eps-upper-y
ebnf-production-vertical-space
ebnf-eps-max-height)))
;; prologue
(goto-char (point-min))
(insert
"%!PS-Adobe-3.0 EPSF-3.0"
"\n%%BoundingBox: 0 0 "
(format "%d %d" (1+ ebnf-eps-upper-x) (1+ ebnf-eps-upper-y))
"\n%%Title: " filename
"\n%%CreationDate: " (format-time-string "%T %b %d %Y")
"\n%%Creator: " (user-full-name) " (using GNU Emacs " emacs-version ")"
"\n%%DocumentNeededResources: font "
(or ebnf-fonts-required
(setq ebnf-fonts-required
(mapconcat #'identity
(delete-dups
(mapcar #'ebnf-font-name-select
(list ebnf-production-font
ebnf-terminal-font
ebnf-non-terminal-font
ebnf-special-font
ebnf-except-font
ebnf-repeat-font
ebnf-eps-header-font
ebnf-eps-footer-font)))
"\n%%+ font ")))
"\n%%Pages: 0\n%%EndComments\n\n%%BeginProlog\n"
ebnf-eps-prologue)
(ebnf-insert-ebnf-prologue)
(insert ebnf-eps-begin
"\n0 " (ebnf-format-float
(- ebnf-eps-upper-y (* ebnf-font-height-P 0.7)))
" #ebnf2ps#begin\n")
;; epilogue
(goto-char (point-max))
(insert ebnf-eps-end)
;; write file
(message "Saving...")
(setq filename (expand-file-name filename))
(let ((coding-system-for-write 'raw-text-unix))
(write-region (point-min) (point-max) filename))
(message "Wrote %s" filename))))
(defun ebnf-insert-ebnf-prologue ()
(insert
(or ebnf-settings
(setq ebnf-settings
(concat
"\n\n% === begin EBNF settings\n\n"
(format "/Header %s def\n"
(or ebnf-eps-header-comment "()"))
(format "/Footer %s def\n"
(or ebnf-eps-footer-comment "()"))
;; header
(format "/ShowHeader %s def\n"
(ebnf-boolean
(ebnf-eps-header-footer-p ebnf-eps-header)))
(format "/fH %s /%s DefFont\n"
(ebnf-format-float
(ebnf-font-size ebnf-eps-header-font))
(ebnf-font-name-select ebnf-eps-header-font))
(ebnf-format-color "/ForegroundH %s def %% %s\n"
(ebnf-font-foreground ebnf-eps-header-font)
"Black")
(ebnf-format-color "/BackgroundH %s def %% %s\n"
(ebnf-font-background ebnf-eps-header-font)
"White")
(format "/EffectH %d def\n"
(ebnf-font-attributes ebnf-eps-header-font))
;; footer
(format "/ShowFooter %s def\n"
(ebnf-boolean
(ebnf-eps-header-footer-p ebnf-eps-footer)))
(format "/fF %s /%s DefFont\n"
(ebnf-format-float
(ebnf-font-size ebnf-eps-footer-font))
(ebnf-font-name-select ebnf-eps-footer-font))
(ebnf-format-color "/ForegroundF %s def %% %s\n"
(ebnf-font-foreground ebnf-eps-footer-font)
"Black")
(ebnf-format-color "/BackgroundF %s def %% %s\n"
(ebnf-font-background ebnf-eps-footer-font)
"White")
(format "/EffectF %d def\n"
(ebnf-font-attributes ebnf-eps-footer-font))
;; production
(format "/fP %s /%s DefFont\n"
(ebnf-format-float (ebnf-font-size ebnf-production-font))
(ebnf-font-name-select ebnf-production-font))
(ebnf-format-color "/ForegroundP %s def %% %s\n"
(ebnf-font-foreground ebnf-production-font)
"Black")
(ebnf-format-color "/BackgroundP %s def %% %s\n"
(ebnf-font-background ebnf-production-font)
"White")
(format "/EffectP %d def\n"
(ebnf-font-attributes ebnf-production-font))
;; terminal
(format "/fT %s /%s DefFont\n"
(ebnf-format-float (ebnf-font-size ebnf-terminal-font))
(ebnf-font-name-select ebnf-terminal-font))
(ebnf-format-color "/ForegroundT %s def %% %s\n"
(ebnf-font-foreground ebnf-terminal-font)
"Black")
(ebnf-format-color "/BackgroundT %s def %% %s\n"
(ebnf-font-background ebnf-terminal-font)
"White")
(format "/EffectT %d def\n"
(ebnf-font-attributes ebnf-terminal-font))
(format "/BorderWidthT %s def\n"
(ebnf-format-float ebnf-terminal-border-width))
(ebnf-format-color "/BorderColorT %s def %% %s\n"
ebnf-terminal-border-color
"Black")
(format "/ShapeT %d def\n"
(ebnf-shape-value ebnf-terminal-shape
ebnf-terminal-shape-alist))
(format "/ShadowT %s def\n"
(ebnf-boolean ebnf-terminal-shadow))
;; non-terminal
(format "/fNT %s /%s DefFont\n"
(ebnf-format-float
(ebnf-font-size ebnf-non-terminal-font))
(ebnf-font-name-select ebnf-non-terminal-font))
(ebnf-format-color "/ForegroundNT %s def %% %s\n"
(ebnf-font-foreground ebnf-non-terminal-font)
"Black")
(ebnf-format-color "/BackgroundNT %s def %% %s\n"
(ebnf-font-background ebnf-non-terminal-font)
"White")
(format "/EffectNT %d def\n"
(ebnf-font-attributes ebnf-non-terminal-font))
(format "/BorderWidthNT %s def\n"
(ebnf-format-float ebnf-non-terminal-border-width))
(ebnf-format-color "/BorderColorNT %s def %% %s\n"
ebnf-non-terminal-border-color
"Black")
(format "/ShapeNT %d def\n"
(ebnf-shape-value ebnf-non-terminal-shape
ebnf-terminal-shape-alist))
(format "/ShadowNT %s def\n"
(ebnf-boolean ebnf-non-terminal-shadow))
;; special
(format "/fS %s /%s DefFont\n"
(ebnf-format-float (ebnf-font-size ebnf-special-font))
(ebnf-font-name-select ebnf-special-font))
(ebnf-format-color "/ForegroundS %s def %% %s\n"
(ebnf-font-foreground ebnf-special-font)
"Black")
(ebnf-format-color "/BackgroundS %s def %% %s\n"
(ebnf-font-background ebnf-special-font)
"Gray95")
(format "/EffectS %d def\n"
(ebnf-font-attributes ebnf-special-font))
(format "/BorderWidthS %s def\n"
(ebnf-format-float ebnf-special-border-width))
(ebnf-format-color "/BorderColorS %s def %% %s\n"
ebnf-special-border-color
"Black")
(format "/ShapeS %d def\n"
(ebnf-shape-value ebnf-special-shape
ebnf-terminal-shape-alist))
(format "/ShadowS %s def\n"
(ebnf-boolean ebnf-special-shadow))
;; except
(format "/fE %s /%s DefFont\n"
(ebnf-format-float (ebnf-font-size ebnf-except-font))
(ebnf-font-name-select ebnf-except-font))
(ebnf-format-color "/ForegroundE %s def %% %s\n"
(ebnf-font-foreground ebnf-except-font)
"Black")
(ebnf-format-color "/BackgroundE %s def %% %s\n"
(ebnf-font-background ebnf-except-font)
"Gray90")
(format "/EffectE %d def\n"
(ebnf-font-attributes ebnf-except-font))
(format "/BorderWidthE %s def\n"
(ebnf-format-float ebnf-except-border-width))
(ebnf-format-color "/BorderColorE %s def %% %s\n"
ebnf-except-border-color
"Black")
(format "/ShapeE %d def\n"
(ebnf-shape-value ebnf-except-shape
ebnf-terminal-shape-alist))
(format "/ShadowE %s def\n"
(ebnf-boolean ebnf-except-shadow))
;; repeat
(format "/fR %s /%s DefFont\n"
(ebnf-format-float (ebnf-font-size ebnf-repeat-font))
(ebnf-font-name-select ebnf-repeat-font))
(ebnf-format-color "/ForegroundR %s def %% %s\n"
(ebnf-font-foreground ebnf-repeat-font)
"Black")
(ebnf-format-color "/BackgroundR %s def %% %s\n"
(ebnf-font-background ebnf-repeat-font)
"Gray85")
(format "/EffectR %d def\n"
(ebnf-font-attributes ebnf-repeat-font))
(format "/BorderWidthR %s def\n"
(ebnf-format-float ebnf-repeat-border-width))
(ebnf-format-color "/BorderColorR %s def %% %s\n"
ebnf-repeat-border-color
"Black")
(format "/ShapeR %d def\n"
(ebnf-shape-value ebnf-repeat-shape
ebnf-terminal-shape-alist))
(format "/ShadowR %s def\n"
(ebnf-boolean ebnf-repeat-shadow))
;; miscellaneous
(format "/ExtraWidth %s def\n"
(ebnf-format-float ebnf-arrow-extra-width))
(format "/ArrowScale %s def\n"
(ebnf-format-float ebnf-arrow-scale))
(format "/DefaultWidth %s def\n"
(ebnf-format-float ebnf-default-width))
(format "/LineWidth %s def\n"
(ebnf-format-float ebnf-line-width))
(ebnf-format-color "/LineColor %s def %% %s\n"
ebnf-line-color
"Black")
(format "/ArrowShape %d def\n"
(ebnf-shape-value ebnf-arrow-shape
ebnf-arrow-shape-alist))
(format "/ChartShape %d def\n"
(ebnf-shape-value ebnf-chart-shape
ebnf-terminal-shape-alist))
(format "/UserArrow{%s}def\n"
(let ((arrow (eval ebnf-user-arrow t)))
(if (stringp arrow)
arrow
"")))
"\n% === end EBNF settings\n\n"
(and ebnf-debug-ps ebnf-debug))))
ebnf-prologue))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Adjusting dimensions
(defun ebnf-dimensions (tree)
(ebnf-log "(ebnf-dimensions tree)")
(let ((ebnf-total (length tree))
(ebnf-nprod 0))
(mapc #'ebnf-production-dimension tree))
tree)
;; [empty width-fun dim-fun entry height width]
;;(defun ebnf-empty-dimension (empty)
;; )
;; [production width-fun dim-fun entry height width name production action]
(defun ebnf-production-dimension (production)
(ebnf-log "(ebnf-production-dimension production)")
(ebnf-message-info "Calculating dimensions")
(ebnf-node-dimension-func (ebnf-node-production production))
(let* ((prod (ebnf-node-production production))
(height (+ (if ebnf-production-name-p
ebnf-font-height-P
0.0)
ebnf-line-width ebnf-line-width
ebnf-basic-height
(ebnf-node-height prod))))
(ebnf-node-entry production height)
(ebnf-node-height production height)
(ebnf-node-width production (+ (ebnf-node-width prod)
ebnf-line-width
ebnf-horizontal-space
ebnf-basic-width-extra)))
(ebnf-log " production name : %S" (ebnf-node-name production))
(ebnf-log " production entry : %7.3f" (ebnf-node-entry production))
(ebnf-log " production height : %7.3f" (ebnf-node-height production))
(ebnf-log " production width : %7.3f" (ebnf-node-width production)))
;; [terminal width-fun dim-fun entry height width name]
(defun ebnf-terminal-dimension (terminal)
(ebnf-log "(ebnf-terminal-dimension terminal)")
(ebnf-terminal-dimension1 terminal
ebnf-font-height-T
ebnf-font-width-T
ebnf-space-T))
;; [non-terminal width-fun dim-fun entry height width name]
(defun ebnf-non-terminal-dimension (non-terminal)
(ebnf-log "(ebnf-non-terminal-dimension non-terminal)")
(ebnf-terminal-dimension1 non-terminal
ebnf-font-height-NT
ebnf-font-width-NT
ebnf-space-NT))
;; [special width-fun dim-fun entry height width name]
(defun ebnf-special-dimension (special)
(ebnf-log "(ebnf-special-dimension special)")
(ebnf-terminal-dimension1 special
ebnf-font-height-S
ebnf-font-width-S
ebnf-space-S))
(defun ebnf-terminal-dimension1 (node font-height font-width space)
(let ((height (+ space font-height space))
(len (length (ebnf-node-name node))))
(ebnf-node-entry node (* height 0.5))
(ebnf-node-height node height)
(ebnf-node-width node (+ ebnf-basic-width
ebnf-arrow-extra-width
space
(* len font-width)
space
ebnf-basic-width)))
(ebnf-log " name : %S" (ebnf-node-name node))
(ebnf-log " entry : %7.3f" (ebnf-node-entry node))
(ebnf-log " height : %7.3f" (ebnf-node-height node))
(ebnf-log " width : %7.3f" (ebnf-node-width node)))
(defconst ebnf-null-vector (vector t t t 0.0 0.0 0.0))
;; [repeat width-fun dim-fun entry height width times element]
(defun ebnf-repeat-dimension (repeat)
(ebnf-log "(ebnf-repeat-dimension repeat)")
(let ((times (ebnf-node-name repeat))
(element (ebnf-node-separator repeat)))
(if element
(ebnf-node-dimension-func element)
(setq element ebnf-null-vector))
(ebnf-node-entry repeat (+ (ebnf-node-entry element)
ebnf-space-R))
(ebnf-node-height repeat (+ (max (ebnf-node-height element)
ebnf-font-height-S)
ebnf-space-R ebnf-space-R))
(ebnf-node-width repeat (+ (ebnf-node-width element)
ebnf-arrow-extra-width
ebnf-space-R ebnf-space-R ebnf-space-R
ebnf-horizontal-space
(* (length times) ebnf-font-width-R))))
(ebnf-log " repeat entry : %7.3f" (ebnf-node-entry repeat))
(ebnf-log " repeat height : %7.3f" (ebnf-node-height repeat))
(ebnf-log " repeat width : %7.3f" (ebnf-node-width repeat)))
;; [except width-fun dim-fun entry height width element element]
(defun ebnf-except-dimension (except)
(ebnf-log "(ebnf-except-dimension except)")
(let ((factor (ebnf-node-list except))
(element (ebnf-node-separator except)))
(ebnf-node-dimension-func factor)
(if element
(ebnf-node-dimension-func element)
(setq element ebnf-null-vector))
(ebnf-node-entry except (+ (max (ebnf-node-entry factor)
(ebnf-node-entry element))
ebnf-space-E))
(ebnf-node-height except (+ (max (ebnf-node-height factor)
(ebnf-node-height element))
ebnf-space-E ebnf-space-E))
(ebnf-node-width except (+ (ebnf-node-width factor)
(ebnf-node-width element)
ebnf-arrow-extra-width
ebnf-space-E ebnf-space-E
ebnf-space-E ebnf-space-E
ebnf-font-width-E
ebnf-horizontal-space)))
(ebnf-log " except entry : %7.3f" (ebnf-node-entry except))
(ebnf-log " except height : %7.3f" (ebnf-node-height except))
(ebnf-log " except width : %7.3f" (ebnf-node-width except)))
;; [alternative width-fun dim-fun entry height width list]
(defun ebnf-alternative-dimension (alternative)
(ebnf-log "(ebnf-alternative-dimension alternative)")
(let ((body (ebnf-node-list alternative))
(lis (ebnf-node-list alternative)))
(while lis
(ebnf-node-dimension-func (car lis))
(setq lis (cdr lis)))
(let ((height 0.0)
(width 0.0)
(alt body)
(tail (car (last body)))
(entry (ebnf-node-entry (car body)))
node)
(while alt
(setq node (car alt)
alt (cdr alt)
height (+ (ebnf-node-height node) height)
width (max (ebnf-node-width node) width)))
(ebnf-adjust-width body width)
(setq height (+ height (* (1- (length body)) ebnf-vertical-space)))
(ebnf-node-entry alternative (+ entry
(ebnf-entry
(- height entry
(- (ebnf-node-height tail)
(ebnf-node-entry tail))))))
(ebnf-node-height alternative height)
(ebnf-node-width alternative (+ width
ebnf-horizontal-space
ebnf-basic-width-extra))
(ebnf-node-list alternative body)))
(ebnf-log " alternative entry : %7.3f" (ebnf-node-entry alternative))
(ebnf-log " alternative height : %7.3f" (ebnf-node-height alternative))
(ebnf-log " alternative width : %7.3f" (ebnf-node-width alternative)))
;; [optional width-fun dim-fun entry height width element]
(defun ebnf-optional-dimension (optional)
(ebnf-log "(ebnf-optional-dimension optional)")
(let ((body (ebnf-node-list optional)))
(ebnf-node-dimension-func body)
(ebnf-node-entry optional (ebnf-node-entry body))
(ebnf-node-height optional (+ (ebnf-node-height body)
ebnf-vertical-space))
(ebnf-node-width optional (+ (ebnf-node-width body)
ebnf-horizontal-space)))
(ebnf-log " optional entry : %7.3f" (ebnf-node-entry optional))
(ebnf-log " optional height : %7.3f" (ebnf-node-height optional))
(ebnf-log " optional width : %7.3f" (ebnf-node-width optional)))
;; [one-or-more width-fun dim-fun entry height width element separator]
(defun ebnf-one-or-more-dimension (or-more)
(ebnf-log "(ebnf-one-or-more-dimension or-more)")
(let ((list-part (ebnf-node-list or-more))
(sep-part (ebnf-node-separator or-more)))
(ebnf-node-dimension-func list-part)
(and sep-part
(ebnf-node-dimension-func sep-part))
(let ((height (+ (if sep-part
(ebnf-node-height sep-part)
ebnf-basic-empty-height)
ebnf-vertical-space
(ebnf-node-height list-part)))
(width (max (if sep-part
(ebnf-node-width sep-part)
0.0)
(ebnf-node-width list-part))))
(when sep-part
(ebnf-adjust-width list-part width)
(ebnf-adjust-width sep-part width))
(ebnf-node-entry or-more (+ (- height
(ebnf-node-height list-part))
(ebnf-node-entry list-part)))
(ebnf-node-height or-more height)
(ebnf-node-width or-more (+ width
ebnf-horizontal-space
ebnf-basic-width-extra))))
(ebnf-log " one-or-more entry : %7.3f" (ebnf-node-entry or-more))
(ebnf-log " one-or-more height : %7.3f" (ebnf-node-height or-more))
(ebnf-log " one-or-more width : %7.3f" (ebnf-node-width or-more)))
;; [zero-or-more width-fun dim-fun entry height width element separator]
(defun ebnf-zero-or-more-dimension (or-more)
(ebnf-log "(ebnf-zero-or-more-dimension or-more)")
(let ((list-part (ebnf-node-list or-more))
(sep-part (ebnf-node-separator or-more)))
(ebnf-node-dimension-func list-part)
(and sep-part
(ebnf-node-dimension-func sep-part))
(let ((height (+ (if sep-part
(ebnf-node-height sep-part)
ebnf-basic-empty-height)
ebnf-vertical-space
(ebnf-node-height list-part)
ebnf-vertical-space))
(width (max (if sep-part
(ebnf-node-width sep-part)
0.0)
(ebnf-node-width list-part))))
(when sep-part
(ebnf-adjust-width list-part width)
(ebnf-adjust-width sep-part width))
(ebnf-node-entry or-more height)
(ebnf-node-height or-more height)
(ebnf-node-width or-more (+ width
ebnf-horizontal-space
ebnf-basic-width-extra))))
(ebnf-log " zero-or-more entry : %7.3f" (ebnf-node-entry or-more))
(ebnf-log " zero-or-more height : %7.3f" (ebnf-node-height or-more))
(ebnf-log " zero-or-more width : %7.3f" (ebnf-node-width or-more)))
;; [sequence width-fun dim-fun entry height width list]
(defun ebnf-sequence-dimension (sequence)
(ebnf-log "(ebnf-sequence-dimension sequence)")
(let ((above 0.0)
(below 0.0)
(width 0.0)
(lis (ebnf-node-list sequence))
entry node)
(while lis
(setq node (car lis)
lis (cdr lis))
(ebnf-node-dimension-func node)
(setq entry (ebnf-node-entry node)
above (max above entry)
below (max below (- (ebnf-node-height node) entry))
width (+ width (ebnf-node-width node))))
(ebnf-node-entry sequence above)
(ebnf-node-height sequence (+ above below))
(ebnf-node-width sequence width))
(ebnf-log " sequence entry : %7.3f" (ebnf-node-entry sequence))
(ebnf-log " sequence height : %7.3f" (ebnf-node-height sequence))
(ebnf-log " sequence width : %7.3f" (ebnf-node-width sequence)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Adjusting width
(defun ebnf-adjust-width (node width)
(cond
((listp node)
(prog1
node
(while node
(setcar node (ebnf-adjust-width (car node) width))
(setq node (cdr node)))))
((vectorp node)
(cond
;; nothing to be done
((= width (ebnf-node-width node))
node)
;; left justify term
((eq ebnf-justify-sequence 'left)
(ebnf-adjust-empty node width nil))
;; right justify terms
((eq ebnf-justify-sequence 'right)
(ebnf-adjust-empty node width t))
;; centralize terms
(t
(ebnf-node-width-func node width)
(ebnf-node-width node width)
node)
))
(t
node)
))
(defun ebnf-adjust-empty (node width last-p)
(if (eq (ebnf-node-kind node) 'ebnf-generate-empty)
(progn
(ebnf-node-width node width)
node)
(let ((empty (ebnf-make-empty (- width (ebnf-node-width node)))))
(ebnf-make-dup-sequence node
(if last-p
(list empty node)
(list node empty))))))
;; [terminal width-fun dim-fun entry height width name]
;; [non-terminal width-fun dim-fun entry height width name]
;; [empty width-fun dim-fun entry height width]
;; [special width-fun dim-fun entry height width name]
;; [repeat width-fun dim-fun entry height width times element]
;; [except width-fun dim-fun entry height width element element]
;;(defun ebnf-terminal-width (terminal width)
;; )
;; [alternative width-fun dim-fun entry height width list]
;; [optional width-fun dim-fun entry height width element]
(defun ebnf-alternative-width (alternative width)
(ebnf-adjust-width (ebnf-node-list alternative)
(- width ebnf-horizontal-space)))
;; [one-or-more width-fun dim-fun entry height width element separator]
;; [zero-or-more width-fun dim-fun entry height width element separator]
(defun ebnf-element-width (or-more width)
(setq width (- width ebnf-horizontal-space))
(ebnf-node-list or-more
(ebnf-justify-list or-more
(ebnf-node-list or-more)
width))
(ebnf-node-separator or-more
(ebnf-justify-list or-more
(ebnf-node-separator or-more)
width)))
;; [sequence width-fun dim-fun entry height width list]
(defun ebnf-sequence-width (sequence width)
(ebnf-node-list sequence
(ebnf-justify-list sequence
(ebnf-node-list sequence)
width)))
(defun ebnf-justify-list (node seq width)
(let ((seq-width (ebnf-node-width node)))
(if (= width seq-width)
seq
(cond
;; left justify terms
((eq ebnf-justify-sequence 'left)
(ebnf-justify node seq seq-width width t))
;; right justify terms
((eq ebnf-justify-sequence 'right)
(ebnf-justify node seq seq-width width nil))
;; centralize terms -- element
((vectorp seq)
(ebnf-adjust-width seq width))
;; centralize terms -- list
(t
(let ((the-width (/ (- width seq-width) (length seq)))
(lis seq))
(while lis
(ebnf-adjust-width (car lis)
(+ (ebnf-node-width (car lis))
the-width))
(setq lis (cdr lis)))
seq))
))))
(defun ebnf-justify (_node seq seq-width width last-p)
(let ((term (car (if last-p (last seq) seq))))
(cond
;; adjust empty term
((eq (ebnf-node-kind term) 'ebnf-generate-empty)
(ebnf-node-width term (+ (- width seq-width)
(ebnf-node-width term)))
seq)
;; insert empty at end ==> left justify
(last-p
(nconc seq
(list (ebnf-make-empty (- width seq-width)))))
;; insert empty at beginning ==> right justify
(t
(cons (ebnf-make-empty (- width seq-width))
seq))
)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions used by parsers
(defun ebnf-eps-add-context (name)
(let ((filename (ebnf-eps-filename name)))
(if (member filename ebnf-eps-context)
(error "Try to open an already opened EPS file: %s" filename)
(setq ebnf-eps-context (cons filename ebnf-eps-context)))
(ebnf-eps-header-footer-file filename)))
(defun ebnf-eps-remove-context (name)
(let ((filename (ebnf-eps-filename name)))
(if (member filename ebnf-eps-context)
(setq ebnf-eps-context (delete filename ebnf-eps-context))
(error "Try to close a not opened EPS file: %s" filename))))
(defun ebnf-eps-add-production (header)
(when ebnf-eps-executing
(if ebnf-eps-context
(let ((prod (assoc header ebnf-eps-production-list)))
(if prod
(setcdr prod (ebnf-dup-list
(append ebnf-eps-context (cdr prod))))
(setq ebnf-eps-production-list
(cons (cons header (ebnf-dup-list ebnf-eps-context))
ebnf-eps-production-list))))
(ebnf-eps-header-footer-file (ebnf-eps-filename header)))))
(defun ebnf-dup-list (old)
(let (new)
(while old
(setq new (cons (car old) new)
old (cdr old)))
(nreverse new)))
(defun ebnf-buffer-substring (chars)
(buffer-substring-no-properties
(point)
(progn
(skip-chars-forward chars ebnf-limit)
(point))))
(defconst ebnf-8-bit-chars "\u00a0-\u00ff")
(defun ebnf-string (chars eos-char kind)
(forward-char)
(buffer-substring-no-properties
(point)
(progn
;;(skip-chars-forward (concat chars "\240-\377") ebnf-limit)
(skip-chars-forward (concat chars ebnf-8-bit-chars) ebnf-limit)
(if (or (eobp) (/= (following-char) eos-char))
(error "Invalid %s: missing `%c'" kind eos-char)
(forward-char)
(1- (point))))))
(defun ebnf-get-string ()
(forward-char)
(buffer-substring-no-properties (point) (ebnf-end-of-string)))
(defun ebnf-end-of-string ()
(let ((n 1))
(while (oddp n)
(skip-chars-forward "^\"" ebnf-limit)
(setq n (- (skip-chars-backward "\\\\")))
(goto-char (+ (point) n 1))))
(if (= (preceding-char) ?\")
(1- (point))
(error "Missing `\"'")))
(defun ebnf-trim-right (str)
(let* ((len (1- (length str)))
(index len))
(while (and (> index 0) (= (aref str index) ?\ ))
(setq index (1- index)))
(if (= index len)
str
(substring str 0 (1+ index)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Vector creation
(defun ebnf-make-empty (&optional width)
(vector 'ebnf-generate-empty ; 0 generator
'ignore ; 1 width fun
'ignore ; 2 dimension fun
0.0 ; 3 entry
0.0 ; 4 height
(or width ebnf-horizontal-space))) ; 5 width
(defun ebnf-make-terminal (name)
(ebnf-make-terminal1 name
'ebnf-generate-terminal
'ebnf-terminal-dimension))
(defun ebnf-make-non-terminal (name)
(ebnf-make-terminal1 name
'ebnf-generate-non-terminal
'ebnf-non-terminal-dimension))
(defun ebnf-make-special (name)
(ebnf-make-terminal1 name
'ebnf-generate-special
'ebnf-special-dimension))
(defun ebnf-make-terminal1 (name gen-func dim-func)
(vector gen-func ; 0 generator
'ignore ; 1 width fun
dim-func ; 2 dimension fun
0.0 ; 3 entry
0.0 ; 4 height
0.0 ; 5 width
(let ((len (length name))) ; 6 name
(cond ((> len 3) name)
((= len 3) (concat name " "))
((= len 2) (concat " " name " "))
((= len 1) (concat " " name " "))
(t " ")))
ebnf-default-p)) ; 7 is default?
(defun ebnf-make-one-or-more (list-part &optional sep-part)
(ebnf-make-or-more1 'ebnf-generate-one-or-more
'ebnf-one-or-more-dimension
list-part
sep-part))
(defun ebnf-make-zero-or-more (list-part &optional sep-part)
(ebnf-make-or-more1 'ebnf-generate-zero-or-more
'ebnf-zero-or-more-dimension
list-part
sep-part))
(defun ebnf-make-or-more1 (gen-func dim-func list-part sep-part)
(vector gen-func ; 0 generator
'ebnf-element-width ; 1 width fun
dim-func ; 2 dimension fun
0.0 ; 3 entry
0.0 ; 4 height
0.0 ; 5 width
(if (listp list-part) ; 6 element
(ebnf-make-sequence list-part)
list-part)
(if (and sep-part (listp sep-part)) ; 7 separator
(ebnf-make-sequence sep-part)
sep-part)))
(defun ebnf-make-production (name prod action)
(vector 'ebnf-generate-production ; 0 generator
'ignore ; 1 width fun
'ebnf-production-dimension ; 2 dimension fun
0.0 ; 3 entry
0.0 ; 4 height
0.0 ; 5 width
name ; 6 production name
prod ; 7 production body
action)) ; 8 production action
(defun ebnf-make-alternative (body)
(vector 'ebnf-generate-alternative ; 0 generator
'ebnf-alternative-width ; 1 width fun
'ebnf-alternative-dimension ; 2 dimension fun
0.0 ; 3 entry
0.0 ; 4 height
0.0 ; 5 width
body)) ; 6 alternative list
(defun ebnf-make-optional (body)
(vector 'ebnf-generate-optional ; 0 generator
'ebnf-alternative-width ; 1 width fun
'ebnf-optional-dimension ; 2 dimension fun
0.0 ; 3 entry
0.0 ; 4 height
0.0 ; 5 width
body)) ; 6 optional element
(defun ebnf-make-except (factor exception)
(vector 'ebnf-generate-except ; 0 generator
'ignore ; 1 width fun
'ebnf-except-dimension ; 2 dimension fun
0.0 ; 3 entry
0.0 ; 4 height
0.0 ; 5 width
factor ; 6 base element
exception)) ; 7 exception element
(defun ebnf-make-repeat (times primary &optional upper)
(vector 'ebnf-generate-repeat ; 0 generator
'ignore ; 1 width fun
'ebnf-repeat-dimension ; 2 dimension fun
0.0 ; 3 entry
0.0 ; 4 height
0.0 ; 5 width
; 6 times
(cond ((and times upper) ; L * U, L * L
(if (string= times upper)
(if (string= times "")
" * "
times)
(concat times " * " upper)))
(times ; L *
(concat times " *"))
(upper ; * U
(concat "* " upper))
(t ; *
" * "))
primary)) ; 7 element
(defun ebnf-make-sequence (seq)
(vector 'ebnf-generate-sequence ; 0 generator
'ebnf-sequence-width ; 1 width fun
'ebnf-sequence-dimension ; 2 dimension fun
0.0 ; 3 entry
0.0 ; 4 height
0.0 ; 5 width
seq)) ; 6 sequence
(defun ebnf-make-dup-sequence (node seq)
(vector 'ebnf-generate-sequence ; 0 generator
'ebnf-sequence-width ; 1 width fun
'ebnf-sequence-dimension ; 2 dimension fun
(ebnf-node-entry node) ; 3 entry
(ebnf-node-height node) ; 4 height
(ebnf-node-width node) ; 5 width
seq)) ; 6 sequence
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Optimizers used by parsers
(defun ebnf-token-except (element exception)
(cons (prog1
(car exception)
(setq exception (cdr exception)))
(and element ; EMPTY - A ==> EMPTY
(let ((kind (ebnf-node-kind element)))
(cond
;; [ A ]- ==> A
((and (null exception)
(eq kind 'ebnf-generate-optional))
(ebnf-node-list element))
;; { A }- ==> { A }+
((and (null exception)
(eq kind 'ebnf-generate-zero-or-more))
(ebnf-node-kind element 'ebnf-generate-one-or-more)
(ebnf-node-dimension-func element 'ebnf-one-or-more-dimension)
element)
;; ( A | EMPTY )- ==> A
;; ( A | B | EMPTY )- ==> A | B
((and (null exception)
(eq kind 'ebnf-generate-alternative)
(eq (ebnf-node-kind
(car (last (ebnf-node-list element))))
'ebnf-generate-empty))
(let ((elt (ebnf-node-list element))
bef)
(while (cdr elt)
(setq bef elt
elt (cdr elt)))
(if (null bef)
;; this should not happen!!?!
(setq element (ebnf-make-empty
(ebnf-node-width element)))
(setcdr bef nil)
(setq elt (ebnf-node-list element))
(and (= (length elt) 1)
(setq element (car elt))))
element))
;; A - B
(t
(ebnf-make-except element exception))
)))))
(defun ebnf-token-repeat (times repeat &optional upper)
(if (null (cdr repeat))
;; n * EMPTY ==> EMPTY
repeat
;; n * term
(cons (car repeat)
(ebnf-make-repeat times (cdr repeat) upper))))
(defun ebnf-token-optional (body)
(let ((kind (ebnf-node-kind body)))
(cond
;; [ EMPTY ] ==> EMPTY
((eq kind 'ebnf-generate-empty)
nil)
;; [ { A }* ] ==> { A }*
((eq kind 'ebnf-generate-zero-or-more)
body)
;; [ { A }+ ] ==> { A }*
((eq kind 'ebnf-generate-one-or-more)
(ebnf-node-kind body 'ebnf-generate-zero-or-more)
body)
;; [ A | B ] ==> A | B | EMPTY
((eq kind 'ebnf-generate-alternative)
(ebnf-node-list body (nconc (ebnf-node-list body)
(list (ebnf-make-empty))))
body)
;; [ A ]
(t
(ebnf-make-optional body))
)))
(defun ebnf-token-alternative (body sequence)
(if (null body)
(if (cdr sequence)
;; no alternative
sequence
;; empty element
(cons (car sequence) ; token
(ebnf-make-empty)))
(cons (car sequence) ; token
(let ((seq (cdr sequence)))
(if (and (= (length body) 1) (null seq))
;; alternative with one element
(car body)
;; a real alternative
(ebnf-make-alternative (nreverse (if seq
(cons seq body)
body))))))))
(defun ebnf-token-sequence (sequence)
(cond
;; null sequence
((null sequence)
(ebnf-make-empty))
;; sequence with only one element
((= (length sequence) 1)
(car sequence))
;; a real sequence
(t
(ebnf-make-sequence (nreverse sequence)))
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Variables used by parsers
(defconst ebnf-comment-table
(let ((table (make-vector 256 nil)))
;; Override special comment character:
(aset table ?< 'newline)
(aset table ?> 'keep-line)
(aset table ?^ 'form-feed)
table)
"Vector used to map characters to a special comment token.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Log message
(defun ebnf-log-header (format-str &rest args)
(when ebnf-log
(apply
#'ebnf-log
(concat
"\n\n===============================================================\n\n"
format-str)
args)))
(defun ebnf-log (format-str &rest args)
(when ebnf-log
(with-current-buffer (get-buffer-create "*Ebnf2ps Log*")
(goto-char (point-max))
(insert (apply #'format-message format-str args) "\n"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To make this file smaller, some commands go in a separate file.
;; But autoload them here to make the separation invisible.
(autoload 'ebnf-abn-parser "ebnf-abn"
"ABNF parser.")
(autoload 'ebnf-abn-initialize "ebnf-abn"
"Initialize ABNF token table.")
(autoload 'ebnf-bnf-parser "ebnf-bnf"
"EBNF parser.")
(autoload 'ebnf-bnf-initialize "ebnf-bnf"
"Initialize EBNF token table.")
(autoload 'ebnf-iso-parser "ebnf-iso"
"ISO EBNF parser.")
(autoload 'ebnf-iso-initialize "ebnf-iso"
"Initialize ISO EBNF token table.")
(autoload 'ebnf-yac-parser "ebnf-yac"
"Yacc/Bison parser.")
(autoload 'ebnf-yac-initialize "ebnf-yac"
"Initializations for Yacc/Bison parser.")
(autoload 'ebnf-ebx-parser "ebnf-ebx"
"EBNFX parser.")
(autoload 'ebnf-ebx-initialize "ebnf-ebx"
"Initializations for EBNFX parser.")
(autoload 'ebnf-dtd-parser "ebnf-dtd"
"DTD parser.")
(autoload 'ebnf-dtd-initialize "ebnf-dtd"
"Initializations for DTD parser.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst ebnf-version "4.4"
"ebnf2ps.el, v 4.4 <2007/02/12 vinicius>
Vinicius's last change version. When reporting bugs, please also
report the version of Emacs, if any, that ebnf2ps was running with.
Please send all bug fixes and enhancements to
bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>.")
(make-obsolete-variable 'ebnf-version 'emacs-version "29.1")
(provide 'ebnf2ps)
;;; ebnf2ps.el ends here
Reference in New Issue View Git Blame Copy Permalink