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 / isr2.lisp < prev    next >
Lisp/Scheme  |  1995-04-11  |  9KB  |  249 lines
  1. ;;; -*- Mode:Common-Lisp; Package:isr2; Base:10 -*-
  2. ;;;------------------------------------------------------------------------
  3. ;;; ISR2.LISP - testing
  4. ;;; Created: Thursday the seventh of April, 1988; 3:57:40 pm
  5. ;;; Author: Robert Heller (Original: Bruce Draper, John Brolio, et. al.)
  6. ;;;------------------------------------------------------------------------
  7. ;;; Copyright (c) University of Massachusetts 1988
  8. ;;;------------------------------------------------------------------------
  9.  
  10. (in-package "ISR2")
  11.  
  12. (unless (find-package 'isr2) 
  13.   (make-package 'isr2))
  14.  
  15. #+:LUCID
  16. (eval-when (load eval compile)
  17.        (when (find-package 'clim)
  18.          (shadowing-import '(clim::format))))
  19.  
  20. #+:allegro 
  21. (eval-when (load eval compile)
  22.        (import '(cltl1::string-char)))
  23.  
  24. (unless (find-package 'isr) (make-package 'isr))
  25. (unless (find-package 'tv) (make-package 'tv))
  26. (unless (find-package 'w) (make-package 'w))
  27. #+:EXPLORER
  28. (unless (fboundp 'user::cdefvar)
  29.   (defmacro cdefvar (variable &optional (initial-value nil) (docstring nil))
  30.   "do defvar unless variable is already bound" 
  31.   ;;-- Bob Collins 5/20
  32.   ;;john brolio 1/7/88 -- to get rid of unspecial variable problem in compiling
  33.   `(eval-when (compile eval load)
  34.      (proclaim '(special ,variable))
  35.      (unless (variable-boundp ,variable)
  36.        (setf ,variable ,initial-value)
  37.        (setf (documentation ',variable 'variable) ,docstring)))))
  38.  
  39.  
  40. (proclaim '(special isr2::*version*))
  41.  
  42. (eval-when (load)
  43.        (setf isr2::*version* 'B1.8)
  44.        (pushnew :isr2 *features*)
  45.        )
  46.  
  47. (export '(handle-canonical-path handle-p handle-type))
  48.  
  49. ;;;;  This macro is commonly used throughout the ISR2
  50.  
  51. #+:EXPLORER
  52. (defmacro cdefvar (variable &optional (initial-value nil) (docstring nil))
  53.   "do defvar unless variable is already bound" 
  54.   ;;john brolio 1/7/88 -- to get rid of unspecial variable problem in compiling
  55.   `(eval-when (compile eval load)
  56.      (proclaim '(special ,variable))
  57.      (unless (variable-boundp ,variable)
  58.        (setf ,variable ,initial-value)
  59.        (setf (documentation ',variable 'variable) ,docstring))))
  60.  
  61.  
  62. #-:EXPLORER
  63. (defmacro isr2::with-lock ((locator . options) &body body)
  64.     (declare (ignore locator options))
  65.     `(progn ,@body))
  66.  
  67. ;;;;
  68. ;;;; DEBUGGING macro
  69. ;;;;
  70. #+:EXPLORER
  71. (cdefvar *DEBUG-ON* nil)
  72. #-:EXPLORER
  73. (defvar *DEBUG-ON* nil)
  74.  
  75. (defmacro DEBUGGING (format &rest args)
  76.   (if *debug-on*
  77.       `(format *debug-io* ,format ,@args)
  78.       '(progn)))
  79.  
  80. (defmacro DEBUG-DESCRIBE (item)
  81.   (if *debug-on*
  82.       `(let ((*standard-output* *debug-io*))
  83.         (describe ,item))
  84.       '(progn)))
  85.  
  86. (defmacro DEBUG-ISR-DESCRIBE (item)
  87.   (if *debug-on*
  88.       `(let ((*standard-output* *debug-io*))
  89.         (isr2::describe-??? ,item))
  90.       '(progn)))
  91.  
  92. ;;;
  93. ;;;isr2.lisp
  94. ;;;
  95. ;;; prototype shell for testing of isr2 structures
  96.  
  97. (defstruct (handle (:print-function print-handle))
  98.   "ISR HANDLE Structure:  This structure is used to represent a path prefix
  99. and provides a \"hook\" into the ISR tree structure."
  100.   type
  101.   frame
  102.   token
  103.   feature
  104.   fdescr
  105.   token-existence-array
  106.   last-picked
  107.   sort-order
  108.   )
  109.  
  110. (defun print-handle (handle stream ignore)
  111.   "Print function for HANDLE structures.  These structures print as if there were
  112. strings describing the canonical path to/through the handle.  The only exception
  113. is a token-(sub)sequence handle.  This is allways printed using #<> notation."
  114.   (declare (ignore ignore))
  115.   (case (handle-type handle)
  116.     (:frame (format stream "#<Frame-Handle ~A>" (frame-path (handle-frame handle))))
  117.     (:token (format stream "#<Token-handle ~A<~A>>" (frame-path (handle-frame handle))
  118.             (handle-token handle)))
  119.     (:frame-feature (format stream "#<Frame-Feature-Handle ~A$~A>"
  120.                 (frame-path (handle-frame handle))
  121.                 (handle-feature handle)))
  122.     (:token-feature (format stream "#<Token-Feature-Handle ~A<~A>~A>"
  123.                 (frame-path (handle-frame handle))
  124.             (handle-token handle) (handle-feature handle)))
  125.     (:token-subset (format stream "#<Token-Subset-Handle ~A>"
  126.                (frame-path (handle-frame handle))))
  127.     (:token-sort (format stream "#<Token-Sort-Handle ~A, :key ~A, :order :~A>"
  128.                (frame-path (handle-frame handle))
  129.                (handle-feature handle)
  130.                (handle-sort-order handle)
  131.                ))
  132.     ))
  133.  
  134. (defun handle-canonical-path (handle)
  135.   "HANDLE-CANONICAL-PATH handle - Returns the canonical path of a handle as
  136. a list of strings."
  137.   (unless (handle-p handle)
  138.     (error "Argument is not a handle: ~S" handle))
  139.   (case (handle-type handle)
  140.     (:frame (frame-path-as-list (handle-frame handle)))
  141.     (:token (nconc (frame-path-as-list (handle-frame handle))
  142.            (let ((index (handle-token handle)))
  143.             (if (integerp index)
  144.                 (list (format nil "<~D>" index))
  145.                 (list "<?>")))))
  146.     (:frame-feature (nconc (frame-path-as-list (handle-frame handle))
  147.                (list (handle-feature handle))))
  148.     (:token-feature (nconc (frame-path-as-list (handle-frame handle))
  149.                (let ((index (handle-token handle)))
  150.                 (if (integerp index)
  151.                     (list (format nil "<~D>" index))
  152.                     (list "<?>")))
  153.                (list (handle-feature handle))))
  154.     ((:token-subset :token-sort)
  155.      (error "Cannot return a canonical path list for ~S")
  156.      handle))
  157.     )
  158.  
  159. (defstruct (frame (:print-function print-frame)(:constructor %make-frame))
  160.   "ISR FRAME Structure - this structure is the basic structure in the ISR.
  161. It is used to hold frame features, tokens, and token features."
  162.   name
  163.   documentation
  164.   source-file-list
  165.   (is-loaded-p t)
  166.   parent
  167.   path-list
  168.   feature-alist
  169.   token-set-feature-vector
  170.   token-set-existence-vector
  171.   token-set-globalp-vector
  172.   )
  173.  
  174. (defun print-frame (frame stream ignore)
  175.   "Print function for FRAME structures."
  176.   (declare (ignore ignore))
  177.   (format stream "#<FRAME ~A>" (frame-path frame)))
  178.  
  179. (defun frame-path (frame &aux elt (result ""))
  180.   "FRAME-PATH frame - return (as a string) the frames's canonical path"
  181.   (do ((path-elt-list (frame-path-list frame) (rest path-elt-list)))
  182.       ((null path-elt-list))
  183.     (setf elt (first path-elt-list))
  184.     (when (integerp elt) (setf elt (format nil "<~d>" elt)))
  185.     (if (and (rest path-elt-list)
  186.          (not (integerp (second path-elt-list)))
  187.          (not (integerp (first path-elt-list))))
  188.     (setf result (concatenate 'string result elt "$"))
  189.     (setf result (concatenate 'string result elt)))
  190.     )
  191.   result)
  192.  
  193. (defun frame-path-as-list (frame &aux elt (result nil))
  194.   "FRAME-PATH frame - return (as a string) the frames's canonical path"
  195.   (do ((path-elt-list (frame-path-list frame) (rest path-elt-list)))
  196.       ((null path-elt-list))
  197.     (setf elt (first path-elt-list))
  198.     (when (integerp elt) (setf elt (format nil "<~d>" elt)))
  199.     (setf result (nconc result (list elt)))
  200.     )
  201.   result)
  202.  
  203. (defun make-frame (name &key (documentation "") (parent nil))
  204.   "MAKE-FRAME name &key (documentation \"\") (parent nil) - primitive function
  205. to build a frame structure."
  206.   ;; argument coercing
  207.   (setf name (string-upcase name)
  208.     documentation (string documentation))
  209.   ;; build a basic frame structure and parse the parent path
  210.   (let ((new-frame (%make-frame :name name :documentation documentation))
  211.     (parsed-parent (make-canonical-path-list (parse-token-name parent)))
  212.     )
  213.     ;; fill in additional slots:
  214.     (setf (frame-parent new-frame) parent ; the parent
  215.       ; the canonical path
  216.       (frame-path-list new-frame) (append parsed-parent (list name))
  217.       ; and an empty token existence vector
  218.       (frame-token-set-existence-vector new-frame)
  219.       (make-2index-vector-vector 0)
  220.       (frame-token-set-globalp-vector new-frame)
  221.       (make-2index-vector-vector 0)
  222.       )
  223.     new-frame))
  224.  
  225. (defun make-canonical-path-list (parent)
  226.   "MAKE-CANONICAL-PATH-LIST parent - make a canonical path list by back traversining
  227. the pathlist of the parent path."
  228.   (cond ((null parent) nil)
  229.     ((handle-p (first parent))
  230.      (case (handle-type (first parent))
  231.        (:frame (append (frame-path-list (handle-frame (first parent)))
  232.                (make-canonical-path-list (rest parent))))
  233.        (:token (append (frame-path-list (handle-frame (first parent)))
  234.                (list (handle-token (first parent)))
  235.                (make-canonical-path-list (rest parent))))
  236.        (:frame-feature (append (frame-path-list
  237.                      (handle-frame (first parent)))
  238.                    (list (handle-feature (first parent)))
  239.                    (make-canonical-path-list (rest parent))))
  240.        (:token-feature (append (frame-path-list
  241.                      (handle-frame (first parent)))
  242.                    (list (handle-token (first parent))
  243.                      (handle-feature (first parent)))
  244.                    (make-canonical-path-list (rest parent))))
  245.        ))
  246.     (t (cons (first parent) (make-canonical-path-list (rest parent)))))
  247.   )
  248.  
  249.