home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume11 / templates / part04 / tplparse.el next >
Lisp/Scheme  |  1987-10-04  |  36KB  |  1,194 lines
  1. ;;; tplparse.el -- Parsing routines for template package
  2. ;;; Copyright (C) 1987 Mark A. Ardis.
  3.  
  4. (require 'tplvars)
  5. (require 'tplhelper)
  6.  
  7. (provide 'tplparse)
  8.  
  9. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  10. ;;; All global variables are in "tplvars"
  11.  
  12. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  13.  
  14. (defun looking-at-tpl ()
  15.   "t if text after point matches specified template."
  16.   (interactive)
  17.                     ; Local Variables
  18.   (let (name-list tpl-name)
  19.                     ; Body
  20.     (setq name-list (tpl-make-completion-list))
  21.     (setq tpl-name (completing-read "looking-at-tpl: Template name? "
  22.                     name-list nil t nil))
  23.     (tpl-looking-at tpl-name)
  24.   ) ; let
  25. ) ; defun looking-at-tpl
  26.  
  27. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  28.  
  29. (defun query-replace-tpl ()
  30.   "Replace some instances of a template with corresponding instances
  31.    of another."
  32.   (interactive)
  33.                     ; Local Variables
  34.   (let (name-list from to)
  35.                     ; Body
  36.     (setq name-list (tpl-make-completion-list))
  37.     (setq from (completing-read "query-replace-tpl: From? "
  38.                     name-list nil t nil))
  39.     (setq to (completing-read (concat "query-replace-tpl: From " from " To? ")
  40.                     name-list nil t nil))
  41.     (tpl-query-replace from to)
  42.   ) ; let
  43. ) ; defun query-replace-tpl
  44.  
  45. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  46.  
  47. (defun replace-tpl ()
  48.   "Replace an instance of a template with a corresponding instance
  49.    of another template."
  50.   (interactive)
  51.                     ; Local Variables
  52.   (let (name-list from to)
  53.                     ; Body
  54.     (setq name-list (tpl-make-completion-list))
  55.     (setq from (completing-read "replace-tpl: From? "
  56.                     name-list nil t nil))
  57.     (setq to (completing-read (concat "replace-tpl: From " from " To? ")
  58.                     name-list nil t nil))
  59.     (while (tpl-search-forward from (point-max) t)
  60.       (exchange-point-and-mark)
  61.       (tpl-replace from to)
  62.       ) ; while
  63.   ) ; let
  64. ) ; defun replace-tpl
  65.  
  66. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  67.  
  68. (defun search-forward-tpl ()
  69.   "Search forward from point for a template."
  70.   (interactive)
  71.                     ; Local Variables
  72.   (let (name-list tpl-name)
  73.                     ; Body
  74.     (setq name-list (tpl-make-completion-list))
  75.     (setq tpl-name (completing-read "search-forward-tpl: Name of template? "
  76.                     name-list nil t nil))
  77.     (tpl-search-forward tpl-name)
  78.   ) ; let
  79. ) ; defun search-forward-tpl
  80.  
  81. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  82.  
  83. (defun tpl-delete-leading-whitespace (text-list)
  84.   "Remove leading whitespace tokens from TEXT-LIST and return remaining list."
  85.                     ; Local Variables
  86.   (let ()
  87.                     ; Body
  88.     (while (and text-list (equal tpl-whitespace-type
  89.                  (tpl-token-name (car text-list))))
  90.       (setq text-list (cdr text-list))
  91.       ) ; while
  92.     ; return
  93.     text-list
  94.     ) ; let
  95.   ) ; defun tpl-delete-leading-whitespace
  96.  
  97. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  98.  
  99. (defun tpl-fix-match (tree old new)
  100.   "Adjust indentation in TREE from OLD to NEW."
  101.                     ; Local Variables
  102.   (let (result token-list token)
  103.                     ; Body
  104.     (if (not new)
  105.     (setq new old)
  106.       ) ; if
  107.     (setq result nil)
  108.     (setq token-list (tpl-token-value tree))
  109.     (while token-list
  110.       (setq token (car token-list))
  111.       (setq token-list (cdr token-list))
  112.       ;(debug nil "token" token)
  113.       (if (and (equal tpl-indentation-type (tpl-token-name token))
  114.            (/= tpl-comment-level (tpl-token-value token)))
  115.       (setq token (tpl-make-token (tpl-token-type token)
  116.                       (tpl-token-name token)
  117.                       (+ (- new old) (tpl-token-value token))))
  118.     ) ; if
  119.       (setq result (append result (list token)))
  120.       ) ; while token-list
  121.     ; return
  122.     result
  123.     ) ; let
  124.   ) ; defun tpl-fix-match
  125.  
  126. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  127.  
  128. (defun tpl-get-match (placeholder tree indent)
  129.   "Find match for PLACEHOLDER in TREE.  Adjust matched value with INDENT."
  130.                     ; Local Variables
  131.   (let (name match token token-type current-indent)
  132.                     ; Body
  133.     (setq name (tpl-token-name (tpl-parse-placeholder (tpl-token-value placeholder))))
  134.     (setq match nil)
  135.     (while (and tree (not match))
  136.       (setq token (car tree))
  137.       (setq tree (cdr tree))
  138.       (setq token-type (tpl-token-type token))
  139.       ;(debug nil "token-type" token-type)
  140.       (if (equal tpl-terminal-type token-type)
  141.       (if (equal tpl-indentation-type (tpl-token-name token))
  142.           (setq current-indent (tpl-token-value token))
  143.         ) ; if (equal tpl-indentation-type (tpl-token-name token))
  144.     ; else
  145.     (if (equal name
  146.            (tpl-token-name
  147.             (tpl-parse-placeholder (tpl-token-name token))))
  148.         (setq match (tpl-fix-match token indent current-indent))
  149.       ) ; if (equal name...)
  150.     ) ; if (equal tpl-terminal-type token-type)
  151.       ) ; while (and tree (not match))
  152.     ; return
  153.     match
  154.     ) ; let
  155.   ) ; defun tpl-get-match
  156.  
  157. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  158.  
  159. (defun tpl-get-placeholder-end (placeholder tpl-name &optional occurrence)
  160.   "Prompt user for end of PLACEHOLDER in TPL-NAME.
  161.    Optional third argument OCCURRENCE specifies which
  162.    occurrence of placeholder to find."
  163.                     ; Local Variables
  164.   (let (template msg return stop size)
  165.                     ; Body
  166.     (if (not occurrence)
  167.     (setq occurrence 1)
  168.       ) ; if
  169.                     ; Get value before changing buffer
  170.     (setq template (tpl-find-template tpl-name))
  171.     (save-window-excursion
  172.       (delete-other-windows)
  173.       (pop-to-buffer (get-buffer-create "*Template*"))
  174.       (erase-buffer)
  175.       (tpl-unscan template)
  176.                     ; Size the window
  177.       (setq stop (point-max))
  178.       (goto-char (point-min))
  179.       (setq size (1+ (count-lines (point) stop)))
  180.       (setq size (max size window-min-height))
  181.       (if (< size (window-height))
  182.       (shrink-window (- (window-height) size))
  183.     ) ; if
  184.                     ; Find the placeholder
  185.       (search-forward placeholder (point-max) t occurrence)
  186.       (other-window 1)
  187.       (setq msg (concat "In \"" tpl-name "\" looking for end of \""
  188.             placeholder "\""))
  189.       (setq return (tpl-get-position (point) (point-max) msg))
  190.       ) ; save-window-excursion
  191.     (bury-buffer "*Template*")
  192.     return
  193.   ) ; let
  194. ) ; defun tpl-get-placeholder-end
  195.  
  196. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  197.  
  198. (defun tpl-get-position (start stop msg &optional start-pos narrow)
  199.   "Prompt user for a location between START and STOP with MSG.
  200.    Optional fourth argument START-POS may be used for initial
  201.    placement of point.  Fifth argument NARROW, if non-nil,
  202.    narrows the region."
  203.                     ; Local Variables
  204.   (let (looking was-modifiable)
  205.                     ; Body
  206.                     ; Check for valid region
  207.     (if (< stop start)
  208.     (error "tpl-get-position: Invalid region specification.")
  209.       ) ; if
  210.                     ; Save current status
  211.     (if (not start-pos)
  212.     (setq start-pos start)
  213.       ) ; if
  214.     (save-restriction
  215.       (if narrow
  216.       (narrow-to-region start stop)
  217.     ) ; if
  218.       (setq was-modifiable (not buffer-read-only))
  219.       (if was-modifiable
  220.       (toggle-read-only)
  221.     ) ; if was-modifiable
  222.       (setq orig-buffer (current-buffer))
  223.                     ; Loop until acceptable answer
  224.       (setq looking t)
  225.       (while looking
  226.     (goto-char start-pos)
  227.     (message msg)
  228.                     ; Wait for user selection
  229.     (recursive-edit)
  230.                     ; Check validity
  231.     (if (or (not (equal orig-buffer (current-buffer)))
  232.         (< (point) start)
  233.         (> (point) stop))
  234.         (progn
  235.           (ding)
  236.           (message "Selected position out of bounds.")
  237.           (sit-for 2)
  238.           (pop-to-buffer orig-buffer)
  239.           (goto-char start-pos)
  240.           ) ; progn
  241.       ; else
  242.       (setq looking nil)
  243.       ) ; if
  244.     ) ; while looking
  245.                     ; Restore original status
  246.       (if was-modifiable
  247.       (toggle-read-only)
  248.     ) ; if was-modifiable
  249.       (if narrow
  250.       (widen)
  251.     ) ; if narrow
  252.       ) ; save-restriction
  253.     (point)                ; return
  254.   ) ; let
  255. ) ; defun tpl-get-position
  256.  
  257. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  258.  
  259. (defun tpl-leading-text (template)
  260.   "Return literal text string at start of TEMPLATE (a name)."
  261.                     ; Local Variables
  262.   (let (body start stop result)
  263.                     ; Body
  264.     (setq body (tpl-find-template template))
  265.     (if (not body)
  266.     (error "Cannot find template.")
  267.       ) ; if (not body)
  268.     (get-buffer-create "*Work*")
  269.     (save-window-excursion
  270.       (set-buffer "*Work*")
  271.       (erase-buffer)
  272.       (tpl-unscan body)
  273.       (goto-char (point-min))
  274.       (setq start (point))
  275.       (end-of-line nil)
  276.       (setq stop (point))
  277.       (goto-char start)
  278.       (if (re-search-forward tpl-begin-placeholder stop start)
  279.       (re-search-backward tpl-begin-placeholder)
  280.     ) ; if
  281.       (setq result (buffer-substring start (point)))
  282.       ) ; save-window-excursion
  283.     ; return
  284.     result
  285.     ) ; let
  286.   ) ; defun tpl-leading-text
  287.  
  288. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  289.  
  290. (defun tpl-line-to-token (tree)
  291.   "Convert TREE from line-format to token-format."
  292.                     ; Local Variables
  293.   (let (line-list line token result type name)
  294.                     ; Body
  295.     (setq result nil)
  296.     (setq type (tpl-token-type tree))
  297.     (setq name (tpl-token-name tree))
  298.     (setq line-list (tpl-token-value tree))
  299.     (while line-list
  300.       (setq line (car line-list))
  301.       (setq line-list (cdr line-list))
  302.       (setq result
  303.         (append result
  304.             (list (tpl-make-token tpl-terminal-type
  305.                       tpl-indentation-type
  306.                       (tpl-line-indent line)))))
  307.       (setq result (append result (tpl-line-tokens line)))
  308.       (if line-list
  309.       (setq result (append result (list tpl-newline-token)))
  310.     ) ; if line-list
  311.       ) ; while line-list
  312.     (setq result (tpl-make-token type name result))
  313.     ; return
  314.     result
  315.     ) ; let
  316.   ) ; defun tpl-line-to-token
  317.  
  318. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  319.  
  320. (defun tpl-looking-at (name)
  321.   "t if text after point matches template NAME"
  322.                     ; Local Variables
  323.   (let (result)
  324.                     ; Body
  325.     (setq result (tpl-match-template name))
  326.     (if result
  327.     t
  328.       nil
  329.       ) ; if
  330.     ) ; let
  331.   ) ; defun tpl-looking-at
  332.  
  333. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  334.  
  335. (defun tpl-match-function-template (template)
  336.   "Match TEMPLATE and return t or nil."
  337.                     ; Local Variables
  338.   (let ()
  339.                     ; Body
  340.     (error "tpl-match-function-type: Cannot match function-type templates.")
  341.     ) ; let
  342.   ) ; defun tpl-match-function-template
  343.  
  344. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  345.  
  346. (defun tpl-match-lexical-template (template)
  347.   "Match TEMPLATE and return t or nil."
  348.                     ; Local Variables
  349.   (let ()
  350.                     ; Body
  351.     (looking-at (tpl-token-value template))
  352.     ) ; let
  353.   ) ; defun tpl-match-lexical-template
  354.  
  355. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  356.  
  357. (defun tpl-match-line (pattern text)
  358.   "Attempt to match the line described by PATTERN with TEXT. Return t or nil."
  359.                     ; Local Variables
  360.   (let (pattern-list text-list next-pattern result success)
  361.                     ; Body
  362.     (if (and text
  363.          (= (tpl-line-indent pattern) (tpl-line-indent text)))
  364.     (progn
  365.       (setq success t)
  366.       (setq pattern-list (tpl-line-tokens pattern))
  367.       (setq text-list (tpl-line-tokens text))
  368.       (while (and pattern-list success text-list)
  369.         (setq next-pattern (car pattern-list))
  370.         (setq pattern-list (cdr pattern-list))
  371.         (setq result (tpl-match-token next-pattern text-list))
  372.         (if result
  373.         (setq text-list (cdr result))
  374.           ; else
  375.           (setq success nil)
  376.           ) ; if result
  377.         ) ; while pattern-list
  378.       ) ; progn
  379.       ; else
  380.       (setq success nil)
  381.       ) ; if (= (tpl-line-indent pattern) (tpl-line-indent text))
  382.     ; return
  383.     success
  384.     ) ; let
  385.   ) ; defun tpl-match-line
  386.  
  387. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  388.  
  389. (defun tpl-match-pattern (pattern-list scanner-patterns)
  390.   "Attempt to match each line in PATTERN-LIST with text after point.
  391.     Return a list of matches.  Second argument SCANNER-PATTERNS
  392.     specifies what type of lexical patterns to use when scanning."
  393.                     ; Local Variables
  394.   (let (success tree this-pattern next-pattern this-match first-text next-text
  395.         start-region start-col
  396.         this-indent next-indent)
  397.                     ; Body
  398.     (setq success t)
  399.     (setq tree nil)
  400.                     ; Initialize scanner
  401.     (setq start-region (point))
  402.     (setq start-col (current-column))
  403.     (setq this-indent 0)
  404.                     ; Get first "next text line"
  405.     (back-to-indentation)
  406.     (setq next-text (tpl-scan-line start-col scanner-patterns))
  407.     (setq this-indent (tpl-line-indent next-text))
  408.     (if (not (eobp))
  409.     (forward-char)
  410.       ) ; if
  411.                     ; For each line in pattern
  412.     (while (and pattern-list success)
  413.       ;(debug nil "top of pattern loop")
  414.                     ; Get next pattern line
  415.       (setq this-pattern (car pattern-list))
  416.       (setq pattern-list (cdr pattern-list))
  417.       (if pattern-list
  418.       (setq next-pattern (car pattern-list))
  419.     ; else
  420.     (setq next-pattern nil)
  421.     ) ; if pattern-list
  422.       (setq this-match nil)
  423.                     ; Get first text line
  424.       (setq first-text next-text)
  425.                     ; Try to match lines
  426.       (if (tpl-match-line this-pattern first-text)
  427.       (progn
  428.         (setq this-match (list first-text))
  429.         (if next-pattern
  430.         (progn
  431.           (setq next-indent (tpl-line-indent next-pattern))
  432.                     ; Get next text line
  433.           (back-to-indentation)
  434.           (setq next-text (tpl-scan-line start-col scanner-patterns))
  435.           (setq this-indent (tpl-line-indent next-text))
  436.           (if (not (eobp))
  437.               (forward-char)
  438.             ) ; if
  439.                     ; Append until next match
  440.           (while (and (not (eobp))
  441.                   (or (> this-indent next-indent)
  442.                   (equal (tpl-line-tokens next-text) nil)))
  443.             ;(debug nil "appending in middle...")
  444.             (setq this-match (append this-match (list next-text)))
  445.                     ; Get next text line
  446.             (back-to-indentation)
  447.             (setq next-text (tpl-scan-line start-col scanner-patterns))
  448.             (setq this-indent (tpl-line-indent next-text))
  449.             (if (not (eobp))
  450.             (forward-char)
  451.               ) ; if
  452.             ) ; while
  453.           ) ; progn
  454.           ; else
  455.                     ; Append until no more indentation
  456.           (progn
  457.         (while (and (not (eobp))
  458.                 (or (> this-indent 0)
  459.                 (equal (tpl-line-tokens next-text) nil)))
  460.           ;(debug nil "appending at end...")
  461.           (setq this-match (append this-match (list next-text)))
  462.                     ; Get next text line
  463.           (back-to-indentation)
  464.           (setq this-col (current-column))
  465.           (setq next-text (tpl-scan-line start-col scanner-patterns))
  466.           (setq this-indent (tpl-line-indent next-text))
  467.           (if (not (eobp))
  468.               (forward-char)
  469.             ) ; if
  470.           ) ; while
  471.         (if (> this-indent 0)
  472.             (setq this-match (append this-match (list next-text)))
  473.           (forward-line -1)
  474.           ) ; if
  475.         ) ; progn
  476.           ) ; if next-pattern
  477.         (setq tree (append tree (list (list this-pattern this-match))))
  478.         ) ; progn
  479.     ; else
  480.     (setq success nil)
  481.     ) ; if (tpl-match-line this-pattern first-text)
  482.       ) ; while pattern-list
  483.     ; Set point and mark
  484.     (if success
  485.     (progn
  486.       (setq success tree)
  487.       (set-mark start-region)
  488.       (if (eobp)
  489.           (end-of-line)
  490.         ; else
  491.         (end-of-line 0)
  492.         ) ; if
  493.       ) ; progn
  494.       ; else
  495.       (goto-char start-region)
  496.       ) ; if success
  497.     ; return
  498.     success
  499.     ) ; let
  500.   ) ; defun tpl-match-pattern
  501.  
  502. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  503.  
  504. (defun tpl-match-repetition-template (template)
  505.   "Match TEMPLATE and return t or nil."
  506.                     ; Local Variables
  507.   (let ()
  508.                     ; Body
  509.     (error
  510.      "tpl-match-repetition-template: Cannot match repetition-type template.")
  511.     ) ; let
  512.   ) ; defun tpl-match-repetition-template
  513.  
  514. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  515.  
  516. (defun tpl-match-selection-template (template)
  517.   "Match TEMPLATE and return tree or nil."
  518.                     ; Local Variables
  519.   (let (result selection-list selection)
  520.                     ; Body
  521.     (setq result nil)
  522.     (setq selection-list (tpl-token-value template))
  523.     (while (and selection-list (not result))
  524.       (setq selection (car selection-list))
  525.       (setq selection-list (cdr selection-list))
  526.       (setq selection (tpl-token-value (car (tpl-line-tokens selection))))
  527.       (setq result (tpl-match-template selection))
  528.       ) ; while selection-list
  529.     ; return
  530.     result
  531.     ) ; let
  532.   ) ; defun tpl-match-selection-template
  533.  
  534. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  535.  
  536. (defun tpl-match-sequence-template (template)
  537.   "Match TEMPLATE and return tree or nil."
  538.                     ; Local Variables
  539.   (let (pattern-list result)
  540.                     ; Body
  541.     (setq pattern-list (tpl-token-value template))
  542.     (setq result (tpl-match-pattern pattern-list lex-patterns))
  543.     (if result
  544.     (setq result (tpl-make-token
  545.               tpl-sequence-type (tpl-token-name template) result))
  546.       ) ; if result
  547.     ; return
  548.     result
  549.     ) ; let
  550.   ) ; defun tpl-match-sequence-template
  551.  
  552. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  553.  
  554. (defun tpl-match-string-template (template)
  555.   "Match TEMPLATE and return tree or nil."
  556.                     ; Local Variables
  557.   (let (pattern-list result)
  558.                     ; Body
  559.     (setq pattern-list (tpl-token-value template))
  560.     (setq result (tpl-match-pattern pattern-list string-patterns))
  561.     (if result
  562.     (setq result (tpl-make-token
  563.               tpl-sequence-type (tpl-token-name template) result))
  564.       ) ; if result
  565.     ; return
  566.     result
  567.     ) ; let
  568.   ) ; defun tpl-match-string-template
  569.  
  570. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  571.  
  572. (defun tpl-match-template (name)
  573.   "Match template NAME and return tree or nil."
  574.                     ; Local Variables
  575.   (let (template template-type result)
  576.                     ; Body
  577.     (setq template (tpl-find-template name))
  578.     (setq template-type (tpl-token-type template))
  579.     (cond
  580.      ((equal template-type tpl-function-type)
  581.       (setq result (tpl-match-function-template template))
  582.       ) ; (equal template-type tpl-function-type)
  583.      ((equal template-type tpl-lexical-type)
  584.       (setq result (tpl-match-lexical-template template))
  585.       ) ; (equal template-type tpl-lexical-type)
  586.      ((equal template-type tpl-repetition-type)
  587.       (setq result (tpl-match-repetition-template template))
  588.       ) ; (equal template-type tpl-repetition-type)
  589.      ((equal template-type tpl-selection-type)
  590.       (setq result (tpl-match-selection-template template))
  591.       ) ; (equal template-type tpl-selection-type)
  592.      ((equal template-type tpl-sequence-type)
  593.       (setq result (tpl-match-sequence-template template))
  594.       ) ; (equal template-type tpl-sequence-type)
  595.      ((equal template-type tpl-string-type)
  596.       (setq result (tpl-match-string-template template))
  597.       ) ; (equal template-type tpl-string-type)
  598.      ) ; cond
  599.     ; return
  600.     result
  601.     ) ; let
  602.   ) ; defun tpl-match-template
  603.  
  604. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  605.  
  606. (defun tpl-match-token (token text-list)
  607.   "Attempt to match TOKEN with tokens in TEXT-LIST.  Return the
  608.     list (t remainder-of-TEXT-LIST) or nil."
  609.                     ; Local Variables
  610.   (let (type success)
  611.                     ; Body
  612.     (setq text-list (tpl-delete-leading-whitespace text-list))
  613.     (setq type (tpl-token-name token))
  614.     (cond
  615.      ((or (equal type tpl-other-type)
  616.       (equal type tpl-punctuation-type)
  617.       (equal type tpl-string-type))
  618.       (progn
  619.     (if text-list
  620.         (progn
  621.           (setq success (equal (tpl-token-value token)
  622.                    (tpl-token-value (car text-list))))
  623.           (setq text-list (cdr text-list))
  624.           ) ; progn
  625.       ; else
  626.       (setq success nil)
  627.       ) ; if text-list
  628.     ) ; progn
  629.       ) ; (or (equal type tpl-other-type)...)
  630.      ((equal type tpl-word-type)
  631.       (progn
  632.     (if text-list
  633.         (progn
  634.           (setq success (equal (upcase (tpl-token-value token))
  635.                    (upcase (tpl-token-value (car text-list)))))
  636.           (setq text-list (cdr text-list))
  637.           ) ; progn
  638.       ; else
  639.       (setq success nil)
  640.       ) ; if text-list
  641.     ) ; progn
  642.       ) ; (equal type tpl-word-type)
  643.      ((equal type tpl-whitespace-type)
  644.       (progn
  645.     (if (and text-list
  646.          (equal tpl-whitespace-type (tpl-token-name (car text-list))))
  647.         (setq text-list (cdr text-list))
  648.       ) ; if
  649.     (setq success t)
  650.     ) ; progn
  651.       ) ; (equal type tpl-whitespace-type)
  652.      ((or (equal type tpl-placeholder-type)
  653.       (equal type tpl-optional-type))
  654.       (progn
  655.     (setq text-list nil)
  656.     (setq success t)
  657.     ) ; progn
  658.       ) ; (equal type tpl-placeholder-type)
  659.      ) ; cond
  660.     (if success
  661.     (setq success (cons t text-list))
  662.       ) ; if success
  663.     ; return
  664.     success
  665.     ) ; let
  666.   ) ; defun tpl-match-token
  667.  
  668. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  669.  
  670. (defun tpl-parse-function (template)
  671.   "Try to parse text at point as an instance of function-type TEMPLATE.
  672.    Return a parse tree or nil."
  673.                     ; Local Variables
  674.   (let ()
  675.                     ; Body
  676.     (error "tpl-parse-function: Cannot parse function-type templates.")
  677.   ) ; let
  678. ) ; defun tpl-parse-function
  679.  
  680. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  681.  
  682. (defun tpl-parse-instance (tpl-name)
  683.   "Try to parse text at point as an instance of TPL-NAME.
  684.    Return a parse tree or nil."
  685.                     ; Local Variables
  686.   (let ()
  687.                     ; Body
  688.     (setq template (tpl-find-template tpl-name))
  689.     (setq template-type (tpl-token-type template))
  690.     (cond
  691.       ((equal template-type tpl-function-type)
  692.     (setq result (tpl-parse-function template))
  693.       ) ; (equal template-type tpl-function-type)
  694.       ((equal template-type tpl-lexical-type)
  695.     (setq result (tpl-parse-lexical template))
  696.       ) ; (equal template-type tpl-lexical-type)
  697.       ((equal template-type tpl-repetition-type)
  698.     (setq result (tpl-parse-repetition template))
  699.       ) ; (equal template-type tpl-repetition-type)
  700.       ((equal template-type tpl-selection-type)
  701.     (setq result (tpl-parse-selection template))
  702.       ) ; (equal template-type tpl-selection-type)
  703.       ((equal template-type tpl-sequence-type)
  704.     (setq result (tpl-parse-sequence template))
  705.       ) ; (equal template-type tpl-sequence-type)
  706.       ((equal template-type tpl-string-type)
  707.     (setq result (tpl-parse-string template))
  708.       ) ; (equal template-type tpl-string-type)
  709.     ) ; cond
  710.     result                ; return
  711.   ) ; let
  712. ) ; defun tpl-parse-instance
  713.  
  714. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  715.  
  716. (defun tpl-parse-lexical (template)
  717.   "Try to parse text at point as an instance of lexical-type TEMPLATE.
  718.    Return a parse tree or nil."
  719.                     ; Local Variables
  720.   (let ()
  721.                     ; Body
  722.     (error "tpl-parse-lexical: Cannot parse lexical-type templates.")
  723.   ) ; let
  724. ) ; defun tpl-parse-lexical
  725.  
  726. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  727.  
  728. (defun tpl-parse-pattern (pattern tpl-name start-col scanner-patterns)
  729.   "Try to parse text at point as an instance of PATTERN within
  730.    template TPL-NAME.  START-COL specifies the starting column of
  731.    the template.  SCANNER-PATTERNS specifies which lexical patterns
  732.    to use when scanning.  Return a token or nil."
  733.                     ; Local Variables
  734.   (let (type result start stop this-col indent-level)
  735.                     ; Body
  736.     (setq type (tpl-token-name pattern))
  737.     (cond
  738.       ((equal type tpl-indentation-type)
  739.     (progn
  740.       (setq result pattern)
  741.       ) ; progn
  742.       ) ; (equal type tpl-indentation-type)
  743.       ((equal type tpl-newline-type)
  744.     (progn
  745.       (setq result pattern)
  746.       ) ; progn
  747.       ) ; (equal type tpl-newline-type)
  748.       ((equal type tpl-other-type)
  749.     (progn
  750.       (tpl-skip-over-whitespace)
  751.       (if (looking-at (tpl-token-value pattern))
  752.           (setq result (tpl-scan-token scanner-patterns))
  753.         (setq result nil)
  754.         ) ; if
  755.       ) ; progn
  756.       ) ; (equal type tpl-other-type)
  757.       ((equal type tpl-placeholder-type)
  758.     (progn
  759.       (tpl-skip-over-whitespace)
  760.       (setq start (point))
  761.       (setq stop (tpl-get-placeholder-end (tpl-token-value pattern)
  762.                           tpl-name))
  763.       (setq result nil)
  764.       (goto-char start)
  765.       (while (< (point) stop)
  766.         (if (eolp)
  767.                     ; This code duplicates some of
  768.                     ;   "tpl-scan-line"
  769.         (progn
  770.           (setq result
  771.             (append result (list tpl-newline-token)))
  772.           (forward-line 1)
  773.           (back-to-indentation)
  774.           (setq this-col (current-column))
  775.           (cond
  776.            ((>= this-col comment-column)
  777.             (progn
  778.               (setq indent-level tpl-comment-level)
  779.               ) ; progn
  780.             ) ; comment
  781.            ((<= this-col start-col)
  782.             (progn
  783.               (setq indent-level 0)
  784.               ) ; progn
  785.             ) ; too small
  786.            (t
  787.             (progn
  788.               (setq indent-level (- this-col start-col))
  789.               ) ; progn
  790.             ) ; t
  791.            ) ; cond
  792.           (setq result
  793.             (append result (list (tpl-make-token
  794.                           tpl-terminal-type
  795.                           tpl-indentation-type
  796.                           indent-level))))
  797.           ) ; progn
  798.           ; else
  799.           (progn
  800.         (setq result
  801.               (append result (list (tpl-scan-token scanner-patterns))))
  802.         ) ; progn
  803.           ) ; if
  804.         ) ; while
  805.       (setq result (tpl-make-token tpl-placeholder-type
  806.                    (tpl-token-value pattern)
  807.                    result))
  808.       ) ; progn
  809.       ) ; (equal type tpl-placeholder-type)
  810.       ((equal type tpl-punctuation-type)
  811.     (progn
  812.       (tpl-skip-over-whitespace)
  813.       (if (looking-at (tpl-token-value pattern))
  814.           (setq result (tpl-scan-token scanner-patterns))
  815.         (setq result nil)
  816.         ) ; if
  817.       ) ; progn
  818.       ) ; (equal type tpl-punctuation-type)
  819.       ((equal type tpl-string-type)
  820.     (progn
  821.       (tpl-skip-over-whitespace)
  822.       (if (looking-at (tpl-token-value pattern))
  823.           (setq result (tpl-scan-token scanner-patterns))
  824.         (setq result nil)
  825.         ) ; if
  826.       ) ; progn
  827.       ) ; (equal type tpl-string-type)
  828.       ((equal type tpl-whitespace-type)
  829.     (progn
  830.       (setq result pattern)
  831.       ) ; progn
  832.       ) ; (equal type tpl-whitespace-type)
  833.       ((equal type tpl-word-type)
  834.     (progn
  835.       (tpl-skip-over-whitespace)
  836.       (if (looking-at (tpl-token-value pattern))
  837.           (setq result (tpl-scan-token scanner-patterns))
  838.         (setq result nil)
  839.         ) ; if
  840.       ) ; progn
  841.       ) ; (equal type tpl-word-type)
  842.     ) ; cond
  843.     result                ; return
  844.   ) ; let
  845. ) ; defun tpl-parse-pattern
  846.  
  847. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  848.  
  849. (defun tpl-parse-placeholder (string)
  850.   "Parse STRING as a placeholder and return token."
  851.                     ; Local Variables
  852.   (let (token)
  853.                     ; Body
  854.     (get-buffer-create "*Work*")
  855.     (save-window-excursion
  856.       (set-buffer "*Work*")
  857.       (erase-buffer)
  858.       (insert string)
  859.       (beginning-of-line)
  860.       (setq token (tpl-scan-placeholder))
  861.       ) ; save-window-excursion
  862.     ; return
  863.     token
  864.     ) ; let
  865.   ) ; defun tpl-parse-placeholder
  866.  
  867. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  868.  
  869. (defun tpl-parse-repetition (template)
  870.   "Try to parse text at point as an instance of repetition-type TEMPLATE.
  871.    Return a parse tree or nil."
  872.                     ; Local Variables
  873.   (let ()
  874.                     ; Body
  875.     (error "tpl-parse-repetition: Cannot parse repetition-type templates.")
  876.   ) ; let
  877. ) ; defun tpl-parse-repetition
  878.  
  879. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  880.  
  881. (defun tpl-parse-selection (template)
  882.   "Try to parse text at point as an instance of selection-type TEMPLATE.
  883.    Return a parse tree or nil."
  884.                     ; Local Variables
  885.   (let ()
  886.                     ; Body
  887.     (error "tpl-parse-selection: Cannot parse selection-type templates.")
  888.   ) ; let
  889. ) ; defun tpl-parse-selection
  890.  
  891. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  892.  
  893. (defun tpl-parse-sequence (template)
  894.   "Try to parse text at point as an instance of sequence-type TEMPLATE.
  895.    Return a parse tree or nil."
  896.                     ; Local Variables
  897.   (let (tpl-name pattern-list pattern result success match start-col)
  898.                     ; Body
  899.     (setq tpl-name (tpl-token-name template))
  900.     (setq pattern-list (tpl-token-value (tpl-line-to-token template)))
  901.     (setq start-col (current-column))
  902.     (setq result nil)
  903.     (setq success t)
  904.     (while (and success pattern-list)
  905.       (setq pattern (car pattern-list))
  906.       (setq pattern-list (cdr pattern-list))
  907.       (setq match (tpl-parse-pattern pattern tpl-name start-col lex-patterns))
  908.       (if match
  909.       (setq result (append result (list match)))
  910.     ; else
  911.     (setq success nil)
  912.     ) ; if match
  913.       ) ; while
  914.     (if success
  915.     result                ; return
  916.       ; else
  917.       nil                ; return
  918.       ) ; if success
  919.   ) ; let
  920. ) ; defun tpl-parse-sequence
  921.  
  922. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  923.  
  924. (defun tpl-parse-string (template)
  925.   "Try to parse text at point as an instance of string-type TEMPLATE.
  926.    Return a parse tree or nil."
  927.                     ; Local Variables
  928.   (let (tpl-name pattern-list pattern result success match start-col)
  929.                     ; Body
  930.     (setq tpl-name (tpl-token-name template))
  931.     (setq pattern-list (tpl-token-value (tpl-line-to-token template)))
  932.     (setq start-col (current-column))
  933.     (setq result nil)
  934.     (setq success t)
  935.     (while (and success pattern-list)
  936.       (setq pattern (car pattern-list))
  937.       (setq pattern-list (cdr pattern-list))
  938.       (setq match (tpl-parse-pattern
  939.            pattern tpl-name start-col string-patterns))
  940.       (if match
  941.       (setq result (append result (list match)))
  942.     ; else
  943.     (setq success nil)
  944.     ) ; if match
  945.       ) ; while
  946.     (if success
  947.     result                ; return
  948.       ; else
  949.       nil                ; return
  950.       ) ; if success
  951.   ) ; let
  952. ) ; defun tpl-parse-string
  953.  
  954. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  955.  
  956. (defun tpl-query-replace (from to)
  957.   "Replace some instances after point matching FROM template with
  958.     corresponding instances of TO.  As each match is found, the user
  959.     must type a character saying what to do with it.  For directions,
  960.     type \\[help-command] at that time."
  961.                     ; Local Variables
  962.   (let ()
  963.                     ; Body
  964.     (perform-replace-tpl from to t nil nil
  965.              'tpl-search-forward
  966.              'exchange-point-and-mark 'tpl-replace)
  967.     ) ; let
  968.   ) ; defun tpl-query-replace
  969.  
  970. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  971.  
  972. (defun tpl-replace (from to)
  973.   "Replace the instance of template FROM with a corresponding instance
  974.     of template TO."
  975.                     ; Local Variables
  976.   (let (token-tree new start)
  977.                     ; Body
  978.     (setq start (point))
  979.     (message (concat "replace-tpl: Trying to match \"" from "\"..."))
  980.     (setq token-tree (tpl-parse-instance from))
  981.     ;(debug nil "token-tree" token-tree)
  982.     (message (concat "replace-tpl: Trying to construct \"" to "\"..."))
  983.     (setq new (tpl-token-to-line (tpl-replace-placeholders to token-tree)))
  984.     ;(debug nil "new tree" new)
  985.     (delete-region start (point))
  986.     (setq start (point))
  987.     (tpl-unscan new)
  988.     (set-mark start)
  989.     (message "replace-tpl: Done.")
  990.     ) ; let
  991.   ) ; defun tpl-replace
  992.  
  993. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  994.  
  995. (defun tpl-replace-placeholders (name tree)
  996.   "Replace placeholders in template NAME using values from TREE."
  997.                     ; Local Variables
  998.   (let (result template token-list token token-type current-indent match)
  999.                     ; Body
  1000.     (setq result nil)
  1001.     (setq template (tpl-find-template name))
  1002.     (if (not (or
  1003.           (equal tpl-sequence-type (tpl-token-type template))
  1004.           (equal tpl-string-type (tpl-token-type template))))
  1005.     (error (concat "tpl-replace-placeholders: "
  1006.                "Target template must be SEQUENCE or STRING type"))
  1007.       ) ; if
  1008.     (setq token-list (tpl-token-value (tpl-line-to-token template)))
  1009.     (while token-list
  1010.       (setq token (car token-list))
  1011.       (setq token-list (cdr token-list))
  1012.       (setq token-type (tpl-token-name token))
  1013.       ;(debug nil "token-type" token-type)
  1014.       (if (or (equal tpl-placeholder-type token-type)
  1015.           (equal tpl-optional-type token-type))
  1016.       (progn
  1017.         (setq match (tpl-get-match token tree current-indent))
  1018.         (if match
  1019.         (setq result (append result match))
  1020.           ; else
  1021.           (setq result (append result (list token)))
  1022.           ) ; if match
  1023.         ) ; progn
  1024.     ; else
  1025.     (progn
  1026.       (if (equal tpl-indentation-type token-type)
  1027.           (setq current-indent (tpl-token-value token))
  1028.         ) ; if (equal tpl-indentation-type token-type)
  1029.       (setq result (append result (list token)))
  1030.       ) ; progn
  1031.     ) ; if (equal tpl-placeholder-type token-type)
  1032.       ) ; while token-list
  1033.     (setq result (tpl-make-token t t result))
  1034.     ; return
  1035.     result
  1036.     ) ; let
  1037.   ) ; defun tpl-replace-placeholders
  1038.  
  1039. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1040.  
  1041. (defun tpl-search-forward (template &optional bound forgiving count)
  1042.   "Search forward from point for TEMPLATE (a name).
  1043.     An optional second argument bounds the search; it is a buffer
  1044.     position.  The match found must not extend beyond that position.
  1045.     Optional third argument, if t, means if fail just return nil
  1046.     (no error).  If not nil and not t, move to limit of search and
  1047.     return nil.  Optional fourth argument is repeat count."
  1048.                     ; Local Variables
  1049.   (let (leading found occur gaveup start trial)
  1050.                     ; Body
  1051.     (setq start (point))
  1052.     (if (not bound)
  1053.     (setq bound (point-max))
  1054.       )
  1055.     (if (not count)
  1056.     (setq count 1)
  1057.       )
  1058.     (setq occur 0)
  1059.     (setq leading (tpl-leading-text template))
  1060.     (if leading
  1061.     (progn
  1062.       (setq found nil)
  1063.       (setq gaveup nil)
  1064.       (while (and (not found) (not gaveup))
  1065.         (if (search-forward leading bound t)
  1066.         (progn
  1067.           (search-backward leading)
  1068.           (setq trial (point))
  1069.           (setq found (tpl-looking-at template))
  1070.           (if (and found
  1071.                (<= (point) bound))
  1072.               (progn
  1073.             (setq occur (1+ occur))
  1074.             (if (< occur count)
  1075.                 (setq found nil)
  1076.               )
  1077.             ) ; progn
  1078.             ; else
  1079.             (if found
  1080.             (setq gaveup t)    ; Out of bounds---no more
  1081.               ; else
  1082.               (progn        ; Failed this time---try again
  1083.             (goto-char trial)
  1084.             (forward-line 1) 
  1085.             ) ; progn
  1086.               ) ; if found
  1087.             ) ; if (and found...)
  1088.           ) ; progn
  1089.           ; else
  1090.           (setq gaveup t)
  1091.           ) ; if (search-forward...)
  1092.         ) ; while
  1093.       ) ; progn
  1094.       ; else
  1095.       (error "Cannot search for templates that start with a placeholder.")
  1096.       ) ; if leading
  1097.     (if (or gaveup (not found))
  1098.     (if (not forgiving)
  1099.         (progn
  1100.           (goto-char bound)
  1101.           (error "Could not find template.")
  1102.           ) ; progn
  1103.       ; else
  1104.       (if (eq forgiving t)
  1105.           (progn
  1106.         (goto-char start)
  1107.         ) ; progn
  1108.         ; else
  1109.         (progn
  1110.           (goto-char bound)
  1111.           ) ; progn
  1112.         ) ; if (eq forgiving t)
  1113.       ) ; if (not forgiving)
  1114.       ) ; if (not found)
  1115.     (if gaveup
  1116.     (setq found nil)
  1117.       ) ; if gaveup
  1118.     ; return
  1119.     found
  1120.     ) ; let
  1121.   ) ; defun tpl-search-forward
  1122.  
  1123. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1124.  
  1125. (defun tpl-skip-over-whitespace ()
  1126.   "Advance point past newlines and whitespace."
  1127.                     ; Local Variables
  1128.   (let (moving)
  1129.                     ; Body
  1130.     (setq moving t)
  1131.     (while (and moving (not (eobp)))
  1132.       (setq moving nil)
  1133.       (if (eolp)
  1134.       (progn
  1135.         (setq moving t)
  1136.         (forward-line 1)
  1137.         ) ; progn
  1138.     ) ; if
  1139.       (if (looking-at tpl-pattern-whitespace)
  1140.       (progn
  1141.         (setq moving t)
  1142.         (re-search-forward tpl-pattern-whitespace)
  1143.         ) ; progn
  1144.     ) ; if
  1145.       ) ; while
  1146.   ) ; let
  1147. ) ; defun tpl-skip-over-whitespace
  1148.  
  1149. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1150.  
  1151. (defun tpl-token-to-line (tree)
  1152.   "Convert TREE from token-format to line-format."
  1153.                     ; Local Variables
  1154.   (let (result line token-list token type name token-type save-indent)
  1155.                     ; Body
  1156.     (setq result nil)
  1157.     (setq line nil)
  1158.     (setq type (tpl-token-type tree))
  1159.     (setq name (tpl-token-name tree))
  1160.     (setq token-list (tpl-token-value tree))
  1161.     (while token-list
  1162.       (setq token (car token-list))
  1163.       (setq token-list (cdr token-list))
  1164.       (setq token-type (tpl-token-name token))
  1165.       (cond
  1166.        ((equal token-type tpl-indentation-type)
  1167.     (progn
  1168.       (setq save-indent (tpl-token-value token))
  1169.       ) ; progn
  1170.     ) ; tpl-indentation-type
  1171.        ((equal token-type tpl-newline-type)
  1172.     (progn
  1173.       (setq result (append result (list (tpl-make-line save-indent line))))
  1174.       (setq line nil)
  1175.       ) ; progn
  1176.     ) ; tpl-newline-type
  1177.        (t
  1178.     (progn
  1179.       (setq line (append line (list token)))
  1180.       ) ; progn
  1181.     ) ; t
  1182.        ) ; cond
  1183.       ) ; while token-list
  1184.     (setq result (append result (list (tpl-make-line save-indent line))))
  1185.     (setq result (tpl-make-token type name result))
  1186.     ; return
  1187.     result
  1188.     ) ; let
  1189.   ) ; defun tpl-token-to-line
  1190.  
  1191. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1192.  
  1193. ;;; end of tplparse.el
  1194.