home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / info-service / www / src / fminit2.0 / mif.ol < prev    next >
Encoding:
Text File  |  1992-11-17  |  3.3 KB  |  143 lines
  1. ;; mif.ol -- the Frame MIF class
  2.  
  3. (require 'objective-lisp)
  4. (require 'stream)
  5.  
  6. (defClass MIF ()
  7.   (out PgfCatalog FontCatalog VariableFormats XRefFormats
  8.        TextFlows MasterPages AFrames body hyper)
  9.   )
  10.  
  11. (defClassMethod MIF :reader (in)
  12.   [MIFReader :new in]
  13.   )
  14.  
  15. (defMethod MIF :isnew (o)
  16.   (setq out o)
  17.   )
  18.  
  19. (defClass MIFReader IStream
  20.   ()
  21.   (table)
  22.   )
  23.  
  24. (defMethod MIFReader :read ()
  25.   [self :set-readtable [self :readtable]]
  26.   (prog1 (send-super :read)
  27.     [self :set-readtable])
  28.   )
  29.  
  30. ;;;;;;;;;;;;;;;
  31. ;;; MIF Syntax
  32.  
  33. (defun read-mif-statement (f c &aux ex ret)
  34.   ;; like (read stream) but uses <> in stead of ()
  35.   (flet ((non-comment-char (comm)
  36.       ;; skip whitespace. skip comm...newline
  37.       ;; return next char
  38.       (do ((c (peek-char t f) (peek-char t f))
  39.            )
  40.           ((not (eql c comm))
  41.            c)
  42.           (read-line f)
  43.           ) )
  44.      )
  45.  
  46.     (do ()
  47.         ((eq (non-comment-char #\#) #\>))
  48.         (let ((cell (cons (read f) nil))
  49.           )
  50.           (if ex (setf (cdr ex) cell) (setf ret cell))
  51.           (setf ex cell)))
  52.     )
  53.   (read-char f) ; toss the trailing #\>
  54.   (cons ret NIL)
  55.   )
  56.  
  57. (defun read-mif-string (f c &aux ex ret nonascii)
  58.   ;; MIF strings look like `lksdjf \n \t \q \Q \x80 lksjdf'
  59.   ;;            aka        "lksdjf \n \009 ` ' \200lksjdf"
  60.   ;; returns a string if all chars are printable ASCII.
  61.   ;; returns a list of characters otherwise
  62.   (labels ((hex-digit (d)
  63.        (or (digit-char-p d)
  64.            (+ 10
  65.           (- (char-int (char-upcase d))
  66.              (char-int #\A))))
  67.        )
  68.  
  69.        (read-mif-char (f)
  70.        ;; interpret mif escapes
  71.        (let ((c (read-char f))
  72.          )
  73.          (if (eq c #\\)
  74.          (case (read-char f)
  75.                (#\> #\>) (#\q #\') (#\Q #\`) (#\\ #\\)
  76.                (#\t (setq nonascii t) (int-char 9))
  77.                (#\x (setq nonascii t)
  78.             (let ((d1 (read-char f))
  79.                   (d2 (read-char f))
  80.                   )
  81.               (read-char f) ;; skip trailing blank
  82.               (int-char (+ (* 16 (hex-digit d1))
  83.                        (hex-digit d2) ))
  84.               ))
  85.                )
  86.            c) ) )
  87.        )
  88.  
  89.       (do ()
  90.           ((eq (peek-char nil f) #\'))
  91.           (let ((cell (cons (read-mif-char f) nil))
  92.             )
  93.         (if ex (setf (cdr ex) cell) (setf ret cell))
  94.         (setf ex cell)))
  95.       (read-char f) ; toss the trailing #\'
  96.       (cons (concatenate (if nonascii 'cons 'string) ret) NIL)
  97.       ) )
  98.  
  99. (defun read-mif-inset (f c &aux ex ret)
  100.   ;; a mif inset looks like:
  101.   ;; =FrameImage
  102.   ;; &lksjdflskdjflsdkj
  103.   ;; &lksdjflsdkjflsdkjf
  104.   ;; =EndInset
  105.   ;;
  106.   (setf ret (setf ex (cons (read f) nil))) ;; read =symbol
  107.   (do ()
  108.       ((not (eq (peek-char t f) #\&)))
  109.       (read-char f) ;; skip &
  110.       (let ((cell (cons (read-line f) nil))
  111.         )
  112.     (setf (cdr ex) cell)
  113.     (setf ex cell)))
  114.   (cons ret NIL))
  115.  
  116. (defMethod MifReader :readtable ()
  117.   (or table
  118.       (progn
  119.     (setq table (subseq *readtable* 0))
  120.     (flet ((setchar (c v)
  121.             (setf (aref table (char-int c))
  122.                   v) )
  123.            )
  124.           (setchar #\< (cons :tmacro #'read-mif-statement))
  125.           (setchar #\` (cons :tmacro #'read-mif-string))
  126.           (setchar #\= (cons :tmacro #'read-mif-inset))
  127.                     ; # is the MIF comment char
  128.           (setchar #\# (aref table (char-int #\;)))
  129.                     ; signal errors on >'s
  130.           (setchar #\>
  131.                (cons :tmacro
  132.                  (lambda (f c)
  133.                    (error "misplaced right angle bracket"))) )
  134.                     ; quote is short for IN, i.e. inch
  135.           (setchar #\" (cons :tmacro
  136.                  (lambda (f c)
  137.                    (cons 'in nil) ) ))
  138.           )
  139.     table
  140.     ) ) )
  141.  
  142. (provide 'Mif)
  143.