home *** CD-ROM | disk | FTP | other *** search
/ vis-ftp.cs.umass.edu / vis-ftp.cs.umass.edu.tar / vis-ftp.cs.umass.edu / pub / Software / ASCENDER / ascendMar8.tar / UMass / ISR / isr2macros.lisp < prev    next >
Text File  |  1995-04-11  |  8KB  |  232 lines
  1. ;;; -*- Mode:Common-Lisp; Package:isr2; Base:10 -*-
  2. ;;;------------------------------------------------------------------------
  3. ;;; ISR2TSS.LISP - Token[sub]sequence functions
  4. ;;; Created: Wed May 18 10:07:22 1988
  5. ;;; Author: Robert Heller
  6. ;;;------------------------------------------------------------------------
  7. ;;; Copyright (c) University of Massachusetts 1988
  8. ;;;------------------------------------------------------------------------
  9.  
  10. (in-package "ISR2")
  11.  
  12. (defmacro for-every-token ((token-var path &optional feature-list) &body body)
  13.   "FOR-EVERY-TOKEN (token-var path &OPTIONAL feature-list) &BODY body -
  14. Traverse the TSS described by path and executes the body with the feature names 
  15. in feature-list bound to token-feature handles indexed to the current token."
  16.    (let ((pathvar      (gensym))
  17.      (parsed-path  (gensym))
  18.      (path-handle  (gensym))
  19.      (more-path    (gensym))
  20.      (frame-handle (gensym))
  21.      (token-index  (gensym))
  22.      )
  23.     (setf feature-list
  24.           (mapcar #'(lambda (fname)
  25.                (intern (string-upcase fname)
  26.                    *package*))
  27.               feature-list))
  28.     `(let* ((,pathvar ,path)
  29.         (,parsed-path (parse-token-name ,pathvar)))
  30.            (multiple-value-bind (,path-handle ,more-path)
  31.          (make-handle-from-parsed-path ,parsed-path)
  32.          (unless (and (handle-p ,path-handle)
  33.                   (check-terminal-path ,path-handle
  34.                            ,more-path)
  35.                   (null ,more-path)
  36.                   (member (handle-type ,path-handle)
  37.                       '(:frame :token-subset :token-sort)))
  38.            (error "~S is not a TSS or TS !" ,pathvar))
  39.          (let ((,frame-handle
  40.              (make-handle :type :frame
  41.                       :frame (handle-frame ,path-handle)))
  42.                (,token-var (make-handle :type :token
  43.                         :frame (handle-frame ,path-handle)
  44.                         :token :?))
  45.                )
  46.               (let ,(mapcar
  47.                   #'(lambda (fname)
  48.                    `(,fname
  49.                       (make-handle
  50.                     :type :token-feature
  51.                     :frame (handle-frame ,frame-handle)
  52.                     :feature ,(string-upcase fname)
  53.                     :token :?
  54.                     :fdescr
  55.                     (or (first (member
  56.                              ,(string-upcase fname)
  57.                              (frame-token-set-feature-vector
  58.                                (handle-frame ,frame-handle))
  59.                              :test #'equalp
  60.                              :key #'fdescr-featurename))
  61.                         (error 
  62.                           "~S is not a token feature of frame ~S"
  63.                           ',fname
  64.                           ,frame-handle)))))
  65.                   feature-list)
  66.                (cond ((eq (handle-type ,path-handle) :frame)
  67.                   (do-active-tokens
  68.                     (,token-index
  69.                       (frame-token-set-globalp-vector
  70.                     (handle-frame
  71.                       ,path-handle)))
  72.                     (setf (handle-token ,token-var)
  73.                       ,token-index
  74.                       ,@(mapcan
  75.                           #'(lambda (fname)
  76.                            `((handle-token
  77.                                ,fname)
  78.                              ,token-index))
  79.                           feature-list)
  80.                       )
  81.                     ,@body))
  82.                  ((typep (handle-token-existence-array
  83.                        ,path-handle)
  84.                      '2index-vector-vector)
  85.                   (do-active-tokens
  86.                     (,token-index
  87.                       (handle-token-existence-array ,path-handle))
  88.                     (setf (handle-token ,token-var) ,token-index)
  89.                     (when (token-exists-p ,token-var)
  90.                       (setf ,@(mapcan
  91.                         #'(lambda (fname)
  92.                               `((handle-token
  93.                                   ,fname)
  94.                                 ,token-index))
  95.                         feature-list)
  96.                         )
  97.                       ,@body))
  98.                   )
  99.                  (t (dolist (,token-index
  100.                           (handle-token-existence-array ,path-handle))
  101.                       (setf (handle-token ,token-var) ,token-index)
  102.                       (when (token-exists-p ,token-var)
  103.                     (setf ,@(mapcan
  104.                           #'(lambda (fname)
  105.                                 `((handle-token
  106.                                 ,fname)
  107.                                   ,token-index))
  108.                           feature-list)
  109.                           )
  110.                     ,@body)))
  111.                  )
  112.                )
  113.               )
  114.          )
  115.            )
  116.     )
  117.    )
  118.  
  119. (defmacro for-every-token! ((token-symbol tokensubset feature-handle-list
  120.                  &key (error-check nil))
  121.                 &body body)
  122.   "Body is executed once for each token in the given tokensubset.  Each time
  123. through the loop, token-symbol is bound to the current token handle.
  124. Feature-handle-list is a list of feature handles from the given tokensubset.
  125. Each time through the loop all feature handles get destructively changed to point
  126. to their respective features for the current token.  By default, no error
  127. checking takes place, but error checking can be forced by specifying the 
  128. error-check key as non-nil.  Error checking tests to see if each feature-handle 
  129. in the feature-handle-list points to a feature in the given tokensubset."
  130.    (let ((echeck (gensym))
  131.      (feat (gensym))
  132.      (tokset (gensym))
  133.      (feat-list (gensym))
  134.      (tokframe (gensym))
  135.      )
  136.     `(let* ((,echeck ,error-check)
  137.         (,tokset (handle ,tokensubset))
  138.         (,feat-list ,feature-handle-list)
  139.         (,tokframe (handle-frame (frame ,tokset)))
  140.         )
  141.           (when ,echeck
  142.         (dolist (,feat ,feat-list)
  143.            (unless (and (handle-p ,feat)
  144.                 (eq (handle-type ,feat) :token-feature)
  145.                 (eq (handle-frame (frame ,feat))
  146.                     ,tokframe)
  147.                 (member (handle-feature ,feat)
  148.                     (frame-token-set-feature-vector ,tokframe)
  149.                     :test #'equalp
  150.                     :key #'fdescr-featurename))
  151.              (error "Bad feature-handle: ~S (tokensubset = ~S)" 
  152.                 ,feat ,tokset))))
  153.           (unwind-protect
  154.         (for-every-token (,token-symbol ,tokset)
  155.                  (map nil #'(lambda (,feat)
  156.                             (setf (handle-token ,feat)
  157.                               (handle-token ,token-symbol)))
  158.                       ,feat-list)
  159.                  ,@body)
  160.         (map nil #'(lambda (,feat)
  161.                    (setf (handle-token ,feat)
  162.                      :?)
  163.                    ) ,feat-list)
  164.         )
  165.           )
  166.     )
  167.    )
  168.  
  169. (defmacro for-every-feature! ((feature-symbol feature-list frame-handle
  170.                    &optional token-handle-list
  171.                    &key (error-check nil))
  172.                   &body body)
  173.   "Body is executed once for each feature in the feature list. Each time through
  174. the loop, feature-symbol is bound to the current feature handle.  Frame-handle
  175. is a reference frame for the feature-list.  Token-handle-list, if given, is a
  176. list of token handles from the same tokensubset. Each time through the loop all
  177. token handles get destructively changed to point to their respective features
  178. for the current feature.  By default, no error checking takes place, but error
  179. checking can be forced by specifying the error-check key as non-nil.  Error
  180. checking tests to see if each token-handle in the token-handle-list points to the
  181. same tokensubset, and that each feature in the feature-list is a valid feature for
  182. that tokensubset."
  183.    (let ((feat-list (gensym))
  184.      (frame-hand (gensym))
  185.      (frame (gensym))
  186.      (token-h-list (gensym))
  187.      (echeck (gensym))
  188.      (feat (gensym))
  189.      (tok (gensym))
  190.      )
  191.     `(let* ((,feat-list ,feature-list)
  192.         (,frame-hand (handle ,frame-handle))
  193.         (,token-h-list ,token-handle-list)
  194.         (,echeck ,error-check)
  195.         (,frame (handle-frame ,frame-hand))
  196.         (,feature-symbol (copy-handle ,frame-hand))
  197.         )
  198.            (when ,echeck
  199.          (dolist (,tok ,token-h-list)
  200.             (unless (and (handle-p ,tok)
  201.                  (eq (handle-type ,tok) :token)
  202.                  (integerp (handle-token ,tok))
  203.                  (eq (handle-frame ,tok) ,frame))
  204.               (error "Token ~S not in frame ~S" ,tok ,frame-hand)))
  205.          (dolist (,feat ,feat-list)
  206.             (unless (member (string ,feat)
  207.                     (frame-token-set-feature-vector ,frame)
  208.                     :test #'equalp
  209.                     :key #'fdescr-featurename)
  210.               (error "feature ~s not in frame ~s" ,feat ,frame-hand))))
  211.            (setf (handle-type ,feature-symbol) :token-feature
  212.              (handle-token ,feature-symbol) :?)
  213.            (dolist (,tok ,token-h-list)
  214.           (setf (handle-type ,tok) :token-feature))
  215.            (unwind-protect
  216.          (dolist (,feat ,feat-list)
  217.            (setf (handle-feature ,feature-symbol) ,feat
  218.              (handle-fdescr ,feature-symbol) 
  219.              (first (member (string ,feat)
  220.                     (frame-token-set-feature-vector ,frame)
  221.                     :test #'equalp
  222.                     :key #'fdescr-featurename)))
  223.            (dolist (,tok ,token-h-list)
  224.               (setf (handle-feature ,tok) (handle-feature ,feature-symbol)
  225.                 (handle-fdescr ,tok) (handle-fdescr ,feature-symbol)))
  226.            ,@body)
  227.          (dolist (,tok ,token-h-list)
  228.             (setf (handle-type ,tok) :token)))
  229.            )
  230.     )
  231.    )
  232.