home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume11 / test.el / part02 / tst-annotate.el < prev    next >
Encoding:
Text File  |  1987-09-08  |  7.4 KB  |  250 lines
  1. ;;; tst-annotate.el --GnuTest Annotation Package
  2. ;;; Copyright (c) 1987 Wang Institute of Graduate Studies
  3.  
  4. ;;; Andy Bliven <bliven@wanginst>
  5. ;;; and Mike Vilot <vilot@wanginst>
  6.  
  7. (provide 'tst-annotate)
  8.  
  9. ;;; ---------------------------------------------------------------------------
  10. ;;; Private Variables--
  11.  
  12. (defvar tst-ann-tricorder nil
  13.   "* The Annotation Database.  A recursive alist implementing a
  14. database indexed by line-number and attribute-name.  Intended to be
  15. accessed only through the tst-ann-* functions."
  16.   )                    ; defvar tst-ann-tricorder
  17.  
  18.  
  19. ;;; ---------------------------------------------------------------------------
  20. ;;; Public Functions--
  21.  
  22. (defun tst-ann-append (line-id attribute value)
  23.   "Appends  VALUE to the list of values for the <LINE-ID ATTRIBUTE> key."
  24.   (let ((oldvalue (tst-ann-get line-id attribute)))
  25.     (if (nlistp oldvalue)
  26.     (error "value must be a list"))
  27.     (tst-ann-put line-id attribute (append oldvalue value))
  28.     )                    ; let
  29.   )
  30.  
  31. (defun tst-ann-format (line-id attribute)
  32.   "Returns a string of format \"LINE-ID: ATTRIBUTE = value\""
  33.   (let ((value (tst-ann-get line-id attribute)))
  34.     (if (null value)
  35.     ""                ; return "" for undefined
  36.       ;; else
  37.       (concat
  38.        (prin1-to-string line-id) ": "
  39.        (prin1-to-string attribute) " = "
  40.        (prin1-to-string value)
  41.        )                ; concat
  42.       )                    ; if
  43.     )                    ; let
  44.   )
  45.  
  46. (defun tst-ann-format-line (line-id)
  47.   "Returns the concatenation of tst-ann-format for every attribute in LINE-ID."
  48.   (mapconcat
  49.    '(lambda (attr)
  50.       (tst-ann-format line-id attr))
  51.    (tst-ann-get-attributes line-id)
  52.    "\n"
  53.    )                    ; concat
  54.   )
  55.  
  56. (defun tst-ann-get (line-id attribute)
  57.   "Retrieves a value for <LINE-ID ATTRIBUTE> key."
  58.   (tst-alist-get (tst-alist-get tst-ann-tricorder line-id) attribute)
  59.   )
  60.  
  61. (defun tst-ann-get-attributes (line-id)
  62.   "Returns a list of attributes defined for LINE-ID."
  63.   (mapcar 'car (tst-alist-get tst-ann-tricorder line-id))
  64.   )
  65.  
  66. (defun tst-ann-get-lines ()
  67.   "Returns a list of lines defined in the anotation database."
  68.   (mapcar 'car tst-ann-tricorder)
  69.   )
  70.  
  71. (defun tst-ann-get-db ()
  72.   "Get database value."
  73.   tst-ann-tricorder
  74.   )
  75.  
  76. (defun tst-ann-inc (line-id attribute)
  77.   "Increments the (assumed numeric) value for <LINE-ID ATTRIBUTE> key."
  78.   (let ((value (car (tst-ann-get line-id attribute))))
  79.     (if (not (numberp value))
  80.     (error "value must be numeric"))
  81.     (tst-ann-put line-id attribute (list (1+ value)))
  82.     )
  83.   )
  84.  
  85. (defun tst-ann-put (line-id attribute value)
  86.   "Associates <LINE-ID ATTRIBUTE> key with VALUE."
  87.   (let ((attr-alist (assoc line-id tst-ann-tricorder)))
  88.     (if (null attr-alist)
  89.     (progn
  90.       (setq tst-ann-tricorder
  91.         (tst-alist-put tst-ann-tricorder line-id nil))
  92.       (setq attr-alist
  93.         (assoc line-id tst-ann-tricorder))
  94.       )                ; progn
  95.       )                    ; if
  96.     (setq attr-alist (tst-alist-put attr-alist attribute value))
  97.     value
  98.     )                    ; let
  99.   )
  100.  
  101. (defun tst-ann-remove (line-id)
  102.   "Removes all data associated with LINE-ID from the database."
  103.   (setq tst-ann-tricorder
  104.     (delq tst-ann-tricorder
  105.           (assoc line-id tst-ann-tricorder)))
  106.   )
  107.  
  108. (defun tst-ann-remove-attribute (line-id attribute)
  109.   "Removes all data associated with both LINE-ID and ATTRIBUTE from the
  110.    database."
  111.   (tst-ann-put line-id attribute nil)
  112.   )
  113.  
  114. (defun tst-ann-set-db (value)
  115.   "Set database to VALUE (either nil or obtained from tst-ann-get-db)."
  116.   (setq tst-ann-tricorder value)
  117.   )
  118.  
  119.  
  120. ;;; ---------------------------------------------------------------------------
  121. ;;; ALIST FUNCTIONS
  122.  
  123. ;;; This is a collection of functions for operating on association
  124. ;;; lists (alists).
  125.  
  126. ;;; SPECIFICATION:  Axiomatic specification of type alist
  127. ;;; 
  128.  
  129. ;;; types--
  130. ;;;   A = association list
  131. ;;;   K = key
  132. ;;;   V = value
  133.  
  134. ;;; signatures--
  135. ;;;   c pre:              -> A   "creates a new alist"
  136. ;;;     post:           A ->     "deletes an alist"
  137. ;;;   c put:    A x K x V -> A   "associate a value with a key"
  138. ;;;     get:        A x K -> V   "retrieve the value associated with a key"
  139. ;;;     rem:        A x K -> A   "remove a key from the list"
  140. ;;;   c app:    A x K x V -> A   "append a key to the list"
  141.  
  142. ;;; rules--
  143. ;;;   (post (pre))            = nil          "successful termination"
  144. ;;;   (post (put A K1 V))     = (post A)
  145. ;;;   (post (app A K1 V))     = (post A)
  146. ;;;   (get (pre) K)           = nil
  147. ;;;   (get (put A K1 V) K2)   = (if (= K1 K2) V (get A K2))
  148. ;;;   (get (app A K1 V) K2)   = (if (= K1 K2) (append (get A K1) V)
  149. ;;;                                           (get A K2))
  150. ;;;   (rem (pre) K1)          = nil
  151. ;;;   (rem (put A K1 V) K2)   = (if (= K1 K2) (rem A K2) (put (rem A K2) K1 V))
  152. ;;;   (rem (app A K1 V) K2)   = (if (= K1 K2) (rem A K2) (app (rem A K2) K1 V))
  153.  
  154. ;;; implementation--
  155. ;;;   an ALIST is represented as a Lisp list, each element of which is a
  156. ;;;     list whose first element is the KEY and the remainder is the VALUE.
  157.  
  158.  
  159. ;;; ----------------------------------------------------------------------
  160. ;;; Alist Functions--
  161.  
  162. (defun tst-alist-get (alist key)
  163.   "generic routine to retrieve from an ALIST the value for KEY."
  164.   (cdr (assoc key alist))
  165.   )                    ; defun tst-alist-get
  166.  
  167. (defun  tst-alist-put (alist key value)
  168.   "Enter into ALIST a <KEY VALUE> pair.  Returns the revised alist; use
  169.    (setq alist (tst-alist-put alist key value)."
  170.  
  171.   (cond ((assoc key alist) (setcdr (assoc key alist) value) alist)
  172.     (t                 (tst-alist-app alist key value))
  173.     )                ; cond
  174.   )                    ; defun tst-alist-put
  175.  
  176. (defmacro tst-alist-rem (alist key)
  177.   "Delete from ALIST the element (KEY value)."
  178.   (list 'setq alist (list 'delq (list 'assoc key alist) alist))
  179.   )                    ; defmacro
  180.  
  181. (defun tst-alist-app (alist key value)
  182.   "Append the <KEY VALUE> pair to ALIST.  Returns a new alist--
  183.    use (setq alist (tst-alist-app alist key value))."
  184.   (nreverse                ; by making the tail the head
  185.    (cons                ; after inserting the new item
  186.     (cons key value)            ; which is a list
  187.     (nreverse alist)            ; placed before the old tail
  188.     )                    ; cons
  189.    )                    ; nreverse
  190.   )                    ; defun tst-alist-app
  191.  
  192.  
  193. ;;; ---------------------------------------------------------------------------
  194. ;;; LIST PRETTY-PRINT FUNCTIONS
  195.  
  196. (defun tst-alist-print (list)
  197.   "Print LIST using prin1 with regular indentation and lots of newlines."
  198.   (interactive "xExpression: ")
  199.   (tst-alist-print-element list (current-column))
  200.   nil
  201.   )
  202.  
  203. (defun tst-alist-print-element (list indent)
  204.   (cond
  205.    ((atom list) (princ list)) 
  206.    ((stringp list) (prin1 list))
  207.    ((vectorp list)
  208.     (princ "[")
  209.     (tst-alist-print-interior list (1+ indent))
  210.     (princ "]"))
  211.    ((listp list)
  212.     (princ "(")
  213.     (tst-alist-print-interior list (1+ indent))
  214.     (princ ")"))
  215.    (t (error "what are you trying to print?"))
  216.    )
  217.   (current-column)
  218.   )
  219.  
  220. (defun tst-alist-print-interior (list indent)
  221.   (let (next)
  222.     (cond
  223.      ((atom list) (tst-alist-print-element list indent))
  224.      ((null (cdr list)) (tst-alist-print-element (car list) indent))
  225.      (t (setq next (tst-alist-print-element (car list) indent))
  226.     (cond        
  227.      ((atom (car list))        ; special case for list of atoms
  228.       (princ " ")
  229.       (setq indent (1+ next))
  230.       ) ; (atom (car list))
  231.      (t                ; normal case--newline between elements
  232.       (princ "\n")
  233.       (tst-alist-print-spaces indent)
  234.       )                ; t
  235.      )                ; cond
  236.     (tst-alist-print-interior (cdr list) indent)
  237.     )                ; t
  238.      )                    ; cond
  239.     )                    ; let
  240.   )
  241.  
  242.  
  243. (defun tst-alist-print-spaces (n)
  244.   (interactive "nColumn:")
  245.   (princ (substring "                                                                                " 0 n))
  246.   nil
  247.   )
  248.     
  249. echo shar: "a missing newline was added to 'tst-annotate.el'"
  250.