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 / obsolete-patch.lisp < prev    next >
Lisp/Scheme  |  1995-04-11  |  2KB  |  55 lines
  1. ;;; -*- Mode:Common-Lisp; Package:ISR2;  Base:10; Patch-file:T -*-
  2. ;;;
  3.  
  4. ;;;  Well, you have to break something, don't you.  We have fixed create
  5. ;;;  frame, on the load band it is wrong.                            6/18/91
  6.  
  7. (defun create-frame (fdescr-handle frame-features token-features)
  8.   "Helper function: create a new frame and define some features for it."
  9.   (unless (and (= (fdescr-type (handle-fdescr fdescr-handle)) *handle*)
  10.            (eq (if (eq (handle-type fdescr-handle) :frame-feature)
  11.                (fdescr-value (handle-fdescr fdescr-handle))
  12.                (vvref (fdescr-value (handle-fdescr fdescr-handle))
  13.                   (handle-token fdescr-handle)))
  14.            *ptr-undefined*))
  15.     (error "Attempt to create a frame in a non-handle feature or in a bound feature: ~S"
  16.        fdescr-handle))
  17.   (let* ((new-frame-name (handle-feature fdescr-handle))
  18.      (new-frame
  19.       (make-frame new-frame-name
  20.               :parent (if (eq (handle-type fdescr-handle) :token-feature)
  21.                   (make-handle :type :token
  22.                            :frame (handle-frame fdescr-handle)
  23.                            :token (handle-token fdescr-handle))
  24.                   (make-handle :type :frame
  25.                            :frame (handle-frame fdescr-handle)))))
  26.      (new-frame-handle (make-handle :type :frame :frame new-frame))
  27.      (new-any-token-index-handle
  28.        (make-handle :type :token
  29.             :frame new-frame
  30.             :token :?))
  31.      (success? nil)
  32.      )
  33.     (setf (value fdescr-handle) new-frame-handle)
  34.     (unwind-protect
  35.       (progn
  36.         (map nil #'(lambda (frame-feature-def)
  37.                    (apply #'define-feature
  38.                       (list new-frame-handle
  39.                         (first frame-feature-def))
  40.                       (rest frame-feature-def)))
  41.          frame-features)
  42.         (map nil #'(lambda (token-feature-def)
  43.                    (apply #'define-feature
  44.                       (list new-any-token-index-handle
  45.                         (first token-feature-def))
  46.                       (rest token-feature-def)))
  47.          token-features)
  48.         (setf success? t))
  49.       (unless success?
  50.         (destroy new-frame-handle)))
  51.     (if success?
  52.         new-frame-handle
  53.         nil))
  54.   )
  55.