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 / isr2parser.lisp < prev    next >
Lisp/Scheme  |  1995-04-11  |  3KB  |  92 lines
  1. ;;; -*- Mode:Common-Lisp; Package:ISR2; Base:10  -*-
  2. ;;;------------------------------------------------------------------------
  3. ;;; ISR2PARSER.LISP - Code to parse token names.
  4. ;;; Created: Friday the eighth of April, 1988; 8:39:26 am
  5. ;;; Author: Robert Heller
  6. ;;;------------------------------------------------------------------------
  7. ;;; Copyright (c) University of Massachusetts 1988
  8. ;;;------------------------------------------------------------------------
  9. ;;
  10. (in-package "ISR2")
  11.  
  12. (export '(parse-token-name))
  13.  
  14. (defun parse-token-name (token-thing)
  15.   "This function parses TOKEN-THING and returns a flat token path list"
  16.   (cond ((null token-thing) nil)        ; Null list is an empty path
  17.     ((symbolp token-thing)            ; Symbol - use printname 
  18.      (parse-token-name (string-upcase token-thing)))
  19.     ((stringp token-thing)            ; Strings - look for delimeters to ckeck
  20.                         ; for further parsing
  21.      (setf token-thing (string-upcase token-thing))
  22.      (when (= (length token-thing) 0)
  23.          (error "Null path elements not allowed: ~S!" token-thing))       
  24.      (let (($-pos (position '#\$ token-thing))
  25.            (<-pos (position '#\< token-thing))
  26.            )
  27.        (if (or $-pos <-pos)
  28.            (parse-token-name-string token-thing)    ; peel off at $ and <
  29.            (list token-thing))))
  30.     ((handle-p token-thing)    (list token-thing))
  31.     ((consp token-thing)   ; a list - map down and flatten it, parsing sub-pieces
  32.                    ; as we go
  33.      (mapcan #'(lambda (old-thing)
  34.              (if (integerp old-thing)
  35.              (list old-thing)
  36.              (parse-token-name old-thing)
  37.              ))
  38.          token-thing))
  39.     (t (error "Bad argument to ISR2:PARSE-TOKEN-NAME - ~S is not a legal token thing"
  40.           token-thing))
  41.     )
  42.   )
  43.  
  44. (defun parse-token-name-string (token-name-string)
  45.   "Helper function to peel apart a token name string."
  46.   (let (($-pos (position '#\$ token-name-string))
  47.     (<-pos (position '#\< token-name-string))
  48.     (tns-len (length token-name-string))
  49.     )
  50.     (cond ((= tns-len 0) nil)
  51.       ((or (and $-pos <-pos (< $-pos <-pos))
  52.            (and $-pos (null <-pos)))
  53.        (when (= $-pos 0)
  54.          (error "Null path elements not allowed: ~S!" token-name-string))
  55.        (cons (subseq token-name-string 0 $-pos)
  56.          (parse-token-name-string (subseq token-name-string (1+ $-pos)))))
  57.       ((or (and $-pos <-pos (> $-pos <-pos))
  58.            (and <-pos (null $-pos)))
  59.        (let* ((p1 (subseq token-name-string 0 <-pos))
  60.           (p2 (subseq token-name-string (1+ <-pos)))
  61.           (>-pos (position '#\> p2))
  62.           )
  63.          (unless >-pos
  64.            (error "Syntax error in token name string: ~S, missing \">\""
  65.               token-name-string))
  66.          (if (and (eql (elt p2 0) '#\?) (= >-pos 1))
  67.          (if (> (length p1) 0)
  68.              (cons p1 (cons :? (parse-token-name-string
  69.                      (subseq p2 (1+ >-pos)))))
  70.              (cons :? (parse-token-name-string
  71.                 (subseq p2 (1+ >-pos)))))
  72.          (multiple-value-bind (tok-indx end-of-num-pos)
  73.              (parse-integer p2 :end >-pos :junk-allowed t :radix #x0A)
  74.            (unless (and tok-indx (= end-of-num-pos >-pos)
  75.                 (>= tok-indx 0))
  76.              (error
  77.                "Syntax error in token name string: ~S, badly formed token index"
  78.                token-name-string))
  79.            (if (> (length p1) 0)
  80.                (cons p1 (cons tok-indx (parse-token-name-string
  81.                          (subseq p2 (1+ >-pos)))))
  82.                (cons tok-indx (parse-token-name-string
  83.                          (subseq p2 (1+ >-pos)))))
  84.            )
  85.          )))
  86.       (t (list token-name-string))
  87.       )
  88.     )
  89.   )
  90.  
  91.  
  92.