home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume11 / templates / part04 / tplscan.el < prev   
Lisp/Scheme  |  1987-10-04  |  13KB  |  412 lines
  1. ;;; tplscan.el -- Scanner for template package
  2. ;;; Copyright (C) 1987 Mark A. Ardis.
  3.  
  4. (require 'tplvars)
  5.  
  6. (provide 'tplscan)
  7.  
  8. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  9. ;;; All global variables are in "tplvars".
  10.  
  11. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  12.  
  13. (defun tpl-make-pattern (pn pv)
  14.   "Constructor for lexical patterns."
  15.   (list (list 'name pn) (list 'value pv))
  16.   ) ; defun tpl-make-pattern
  17.  
  18. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  19.  
  20. (defun tpl-pattern-name (p)
  21.   "Selector for name field of lexical patterns."
  22.   (car (cdr (assq 'name p)))
  23.   ) ; defun tpl-pattern-name
  24.  
  25. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  26.  
  27. (defun tpl-pattern-value (p)
  28.   "Selector for value field of lexical patterns."
  29.   (car (cdr (assq 'value p)))
  30.   ) ; defun tpl-pattern-value
  31.  
  32. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  33.  
  34. (defun tpl-make-token (tt tn tv)
  35.   "Constructor for tokens."
  36.   (list (list 'type tt) (list 'name tn) (list 'value tv))
  37.   ) ; defun tpl-make-token
  38.  
  39. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  40.  
  41. (defun tpl-token-type (token)
  42.   "Selector for type field of tokens."
  43.   (car (cdr (assq 'type token)))
  44.   ) ; defun tpl-token-type
  45.  
  46. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  47.  
  48. (defun tpl-token-name (token)
  49.   "Selector for name field of tokens."
  50.   (car (cdr (assq 'name token)))
  51.   ) ; defun tpl-token-name
  52.  
  53. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  54.  
  55. (defun tpl-token-value (token)
  56.   "Selector for value field of tokens."
  57.   (car (cdr (assq 'value token)))
  58.   ) ; defun tpl-token-value
  59.  
  60. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  61.  
  62. (defun tpl-make-line (indent-level token-list)
  63.   "Constructor for lines."
  64.   (list (list 'indent indent-level) (list 'tokens token-list))
  65.   ) ; defun tpl-make-line
  66.  
  67. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  68.  
  69. (defun tpl-line-indent (line)
  70.   "Selector for indentation field of lines."
  71.   (car (cdr (assq 'indent line)))
  72.   ) ; defun tpl-line-indent
  73.  
  74. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  75.  
  76. (defun tpl-line-tokens (line)
  77.   "Selector for token-list field of lines."
  78.   (car (cdr (assq 'tokens line)))
  79.   ) ; defun tpl-line-tokens
  80.  
  81. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  82.  
  83. (defun tpl-scan-region (start stop pattern-list)
  84.   "Scan the text between START and STOP using PATTERN-LIST for tokens.
  85.    Return an indented line-list of tokens."
  86.                     ; Local Variables
  87.   (let (start-col last-col this-col indent-level last-indent
  88.           line line-list more)
  89.                     ; Body
  90.     (goto-char start)
  91.     (setq start-col (current-column))
  92.     (setq line-list nil)
  93.     (save-restriction
  94.       (narrow-to-region start stop)
  95.       (and (boundp 'template-scan-hook)
  96.        template-scan-hook
  97.        (funcall template-scan-hook))
  98.       (if (eobp)
  99.       (setq more nil)
  100.     (setq more t)
  101.     ) ; if (eobp)
  102.       (while more
  103.                     ; Scan a line
  104.     (back-to-indentation)
  105.     (setq line (tpl-scan-line start-col pattern-list))
  106.     (setq line-list (append line-list (list line)))
  107.                     ; Advance to next line
  108.     (if (not (eobp))
  109.         (forward-char)
  110.       (setq more nil)
  111.       ) ; if (not (eobp))
  112.     ) ; while more
  113.       ) ; save-restriction
  114.                     ; return
  115.     line-list
  116.     ) ; let
  117.   ) ; defun tpl-scan-region
  118.  
  119. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  120.  
  121. (defun tpl-scan-line (start-col pattern-list)
  122.   "Scan a line of text, returning an indentation-line of tokens.
  123.    START-COL is the origin column for a region.
  124.    PATTERN-LIST is the list of tokens to scan for."
  125.                     ; Local Variables
  126.   (let (this-col indent-level line)
  127.                     ; Body
  128.     (if tpl-literal-whitespace
  129.     (progn
  130.       (beginning-of-line nil)
  131.       (setq line (tpl-make-line 0 (tpl-scan-token-list pattern-list)))
  132.       ) ; progn
  133.       ; else
  134.       (progn
  135.     (back-to-indentation)
  136.     (setq this-col (current-column))
  137.     (cond
  138.      ((>= this-col comment-column)
  139.       (progn
  140.         (setq indent-level tpl-comment-level)
  141.         ) ; progn
  142.       ) ; comment
  143.      ((<= this-col start-col)
  144.       (progn
  145.         (setq indent-level 0)
  146.         ) ; progn
  147.       ) ; too small
  148.      (t
  149.       (progn
  150.         (setq indent-level (- this-col start-col))
  151.         ) ; progn
  152.       ) ; t
  153.      ) ; cond
  154.                     ; Scan tokens and make into a line
  155.     (setq line (tpl-make-line indent-level
  156.                   (tpl-scan-token-list pattern-list)))
  157.     ) ; progn
  158.       ) ; if tpl-literal-whitespace
  159.                     ; return
  160.     line
  161.     ) ; let
  162.   ) ; defun tpl-scan-line
  163.  
  164. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  165.  
  166. (defun tpl-scan-token (pattern-list)
  167.   "Scan the text at point and return a token.
  168.    PATTERN-LIST is the list of tokens to scan for."
  169.                     ; Local Variables
  170.   (let (pattern pn pv token found start)
  171.                     ; Body
  172.     (setq found nil)
  173.     (while (and pattern-list (not found))
  174.       (setq pattern (car pattern-list))
  175.       (setq pattern-list (cdr pattern-list))
  176.       (setq pn (tpl-pattern-name pattern))
  177.       (setq pv (tpl-pattern-value pattern))
  178.       (if (looking-at pv)
  179.       (setq found t)
  180.     ) ; if (looking-at pattern)
  181.       ) ; while (and pattern-list (not found))
  182.     (if (not found)
  183.     (error "Unable to scan text.")
  184.       ) ; if (not found)
  185.     (setq start (point))
  186.     (re-search-forward pv)
  187.     (setq token (tpl-make-token tpl-terminal-type pn
  188.                 (buffer-substring start (point))))
  189.     token                ; return
  190.     ) ; let
  191.   ) ; defun tpl-scan-token
  192.  
  193. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  194.  
  195. (defun tpl-scan-token-list (pattern-list)
  196.   "Scan the current line and return a list of tokens.
  197.    PATTERN-LIST is the list of tokens to scan for."
  198.                     ; Local Variables
  199.   (let (save-list token token-list)
  200.                     ; Body
  201.     (setq token-list nil)
  202.     (setq save-list pattern-list)
  203.     (while (not (eolp))
  204.       (setq pattern-list save-list)
  205.       (setq token (tpl-scan-token pattern-list))
  206.       (setq token-list (append token-list (list token)))
  207.       ) ; while (not (eolp))
  208.                     ; return
  209.     token-list
  210.     ) ; let
  211.   ) ; defun tpl-scan-token-list
  212.  
  213. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  214.  
  215. (defun tpl-scan-template ()
  216.   "Scan the template at point and return its tree value."
  217.                     ; Local Variables
  218.   (let (start template-name template-type token-list tree save-patterns)
  219.                     ; Body
  220.     (re-search-forward tpl-begin-template-definition)
  221.     (re-search-forward tpl-pattern-whitespace)
  222.     (setq start (point))
  223.     (re-search-forward tpl-pattern-symbol)
  224.     (setq template-name (buffer-substring start (point)))
  225.     (re-search-forward tpl-pattern-whitespace)
  226.     (setq start (point))
  227.     (re-search-forward tpl-pattern-word)
  228.     (setq template-type (buffer-substring start (point)))
  229.     (re-search-forward tpl-begin-template-body)
  230.     (beginning-of-line 2)
  231.     (setq start (point))
  232.     (re-search-forward tpl-end-template-body)
  233.     (end-of-line 0)
  234.     (if (or (equal template-type tpl-lexical-type)
  235.         (equal template-type tpl-function-type))
  236.     (setq token-list (buffer-substring start (point)))
  237.       ; else
  238.       (if (equal template-type tpl-string-type)
  239.       (setq token-list (tpl-scan-region start (point) string-patterns))
  240.     ; else
  241.     (setq token-list (tpl-scan-region start (point) lex-patterns))
  242.     ) ; if (equal template-type tpl-string-type)
  243.       ) ; if (or ...)
  244.     (setq tree (tpl-make-token template-type template-name token-list))
  245.                     ; return
  246.     tree
  247.     ) ; let
  248.   ) ; defun tpl-scan-template
  249.  
  250. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  251.  
  252. (defun tpl-scan-placeholder ()
  253.   "Scan the placeholder at point and return its tree value."
  254.                     ; Local Variables
  255.   (let (save start placeholder-type placeholder-name token-type)
  256.                     ; Body
  257.     (setq save (point))
  258.     (re-search-forward tpl-begin-placeholder)
  259.     (if (looking-at tpl-pattern-optional)
  260.     (progn
  261.       (setq token-type tpl-optional-type)
  262.       (re-search-forward tpl-pattern-optional)
  263.       ) ; progn
  264.       ; else
  265.       (progn
  266.     (setq token-type tpl-placeholder-type)
  267.     ) ; progn
  268.       ) ; if (looking-at tpl-pattern-optional)
  269.     (setq start (point))
  270.     (if (looking-at tpl-destination-symbol)
  271.     (forward-char (length tpl-destination-symbol))
  272.       (re-search-forward tpl-pattern-symbol)
  273.       ) ; if
  274.     (setq placeholder-type (buffer-substring start (point)))
  275.     (if (looking-at tpl-sep-placeholder)
  276.     (progn
  277.       (re-search-forward tpl-sep-placeholder)
  278.       (setq start (point))
  279.       (re-search-forward tpl-pattern-symbol)
  280.       (setq placeholder-name (buffer-substring start (point)))
  281.       ) ; progn
  282.       ; else
  283.       (progn
  284.     (setq placeholder-name nil)
  285.     ) ; progn
  286.       ) ; if (looking-at tpl-sep-placeholder)
  287.     (setq placeholder (tpl-make-token
  288.                token-type
  289.                placeholder-type
  290.                placeholder-name))
  291.     (goto-char save)
  292.                     ; return
  293.     placeholder
  294.     ) ; let
  295.   ) ; defun tpl-scan-placeholder
  296.  
  297. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  298.  
  299. (defun tpl-unscan (token &optional column)
  300.   "Insert at point the values of tokens in the tree rooted by TOKEN.
  301.      Optional second argument COLUMN specifies where to indent rigidly.
  302.      Default is the current column."
  303.                     ; Local Variables
  304.   (let (begin-template start-column token-list line-list line save-hook)
  305.                     ; Body
  306.                     ; Save auto-fill-hook and reset
  307.     (setq save-hook auto-fill-hook)
  308.     (if (not tpl-fill-while-unscanning)
  309.     (setq auto-fill-hook nil)
  310.       ) ; if
  311.                     ; Unscan template
  312.     (setq begin-template (point))
  313.     (if column
  314.     (setq start-column column)
  315.       ; else
  316.       (setq start-column (current-column))
  317.       ) ; if column
  318.     (setq line-list (tpl-token-value token))
  319.     (while line-list
  320.       (setq line (car line-list))
  321.       (setq line-list (cdr line-list))
  322.       (if (= tpl-comment-level (tpl-line-indent line))
  323.       (indent-to comment-column)
  324.     ; else
  325.     (indent-to (+ start-column (tpl-line-indent line)))
  326.     ) ; if
  327.       (setq token-list (tpl-line-tokens line))
  328.       (while token-list
  329.     (setq token (car token-list))
  330.     (setq token-list (cdr token-list))
  331.     ;(debug "tpl-unscan token:" token)
  332.     (insert-before-markers (tpl-token-value token))
  333.     ) ; while token-list
  334.       (if line-list
  335.       (newline)
  336.     ) ; if line-list
  337.       ) ; while line-list
  338.     (if (and (boundp 'template-unscan-hook)
  339.          template-unscan-hook)
  340.     (funcall template-unscan-hook begin-template (point) start-column)
  341.       ) ; if
  342.                     ; Reset auto-fill-hook
  343.     (setq auto-fill-hook save-hook)
  344.     ) ; let
  345.   ) ; defun tpl-unscan
  346.  
  347. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  348.  
  349. (defun tpl-fix-syntax (string)
  350.   "Change any syntax entries in STRING from (word or symbol or quote)
  351.    to punctuation."
  352.                     ; Local Variables
  353.   (let (char)
  354.                     ; Body
  355.     (while (> (length string) 0)
  356.       (setq char (string-to-char string))
  357.       (setq string (substring string 1))
  358.       (if (or (equal (char-syntax char) ? )
  359.           (equal (char-syntax char) ?_)
  360.           (equal (char-syntax char) ?'))
  361.       (modify-syntax-entry char ".   ")
  362.     ) ; if
  363.       ) ; while
  364.     ) ; let
  365.   ) ; defun tpl-fix-syntax
  366.  
  367. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  368.  
  369. (defun tpl-initialize-scan ()
  370.   "Initialize environment for scan."
  371.                     ; Local Variables
  372.   (let ()
  373.                     ; Body
  374.                     ; Make all characters non-symbols
  375.     (tpl-fix-syntax tpl-begin-placeholder)
  376.     (tpl-fix-syntax tpl-end-placeholder)
  377.     (tpl-fix-syntax tpl-sep-placeholder)
  378.     (tpl-fix-syntax tpl-pattern-optional)
  379.                     ; Build composite patterns
  380.     (setq tpl-begin-optional (concat tpl-begin-placeholder
  381.                      tpl-pattern-optional))
  382.     (setq tpl-destination-placeholder (concat tpl-begin-placeholder
  383.                           tpl-destination-symbol
  384.                           tpl-end-placeholder))
  385.     (setq tpl-pattern-placeholder (concat tpl-begin-placeholder
  386.                       "\\(" tpl-pattern-optional "\\)?"
  387.                       tpl-pattern-symbol
  388.                       "\\(" tpl-sep-placeholder
  389.                       tpl-pattern-symbol "\\)?"
  390.                       tpl-end-placeholder))
  391.                     ; Build lexical patterns
  392.     (setq lex-patterns
  393.       (list
  394.        (tpl-make-pattern tpl-placeholder-type tpl-pattern-placeholder)
  395.        (tpl-make-pattern tpl-whitespace-type tpl-pattern-whitespace)
  396.        (tpl-make-pattern tpl-word-type tpl-pattern-word)
  397.        (tpl-make-pattern tpl-punctuation-type tpl-pattern-punctuation)
  398.        (tpl-make-pattern tpl-other-type tpl-pattern-other)
  399.        ))
  400.     (setq string-patterns
  401.       (list
  402.        (tpl-make-pattern tpl-string-type tpl-pattern-string)
  403.        ))
  404.     (setq tpl-newline-token
  405.       (tpl-make-token tpl-terminal-type tpl-newline-type nil))
  406.     ) ; let
  407.   ) ; defun tpl-initialize-scan
  408.  
  409. ;;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  410.  
  411. ;;; end of tplscan.el
  412.