;; mif.ol -- the Frame MIF class

(require 'objective-lisp)
(require 'stream)

(defClass MIF ()
  (out PgfCatalog FontCatalog VariableFormats XRefFormats
       TextFlows MasterPages AFrames body hyper)
  )

(defClassMethod MIF :reader (in)
  [MIFReader :new in]
  )

(defMethod MIF :isnew (o)
  (setq out o)
  )

(defClass MIFReader IStream
  ()
  (table)
  )

(defMethod MIFReader :read ()
  [self :set-readtable [self :readtable]]
  (prog1 (send-super :read)
    [self :set-readtable])
  )

;;;;;;;;;;;;;;;
;;; MIF Syntax

(defun read-mif-statement (f c &aux ex ret)
  ;; like (read stream) but uses <> in stead of ()
  (flet ((non-comment-char (comm)
	  ;; skip whitespace. skip comm...newline
	  ;; return next char
	  (do ((c (peek-char t f) (peek-char t f))
	       )
	      ((not (eql c comm))
	       c)
	      (read-line f)
	      ) )
	 )

	(do ()
	    ((eq (non-comment-char #\#) #\>))
	    (let ((cell (cons (read f) nil))
		  )
	      (if ex (setf (cdr ex) cell) (setf ret cell))
	      (setf ex cell)))
	)
  (read-char f) ; toss the trailing #\>
  (cons ret NIL)
  )

(defun read-mif-string (f c &aux ex ret nonascii)
  ;; MIF strings look like `lksdjf \n \t \q \Q \x80 lksjdf'
  ;;            aka        "lksdjf \n \009 ` ' \200lksjdf"
  ;; returns a string if all chars are printable ASCII.
  ;; returns a list of characters otherwise
  (labels ((hex-digit (d)
	   (or (digit-char-p d)
	       (+ 10
		  (- (char-int (char-upcase d))
		     (char-int #\A))))
	   )

	   (read-mif-char (f)
	   ;; interpret mif escapes
	   (let ((c (read-char f))
		 )
	     (if (eq c #\\)
		 (case (read-char f)
		       (#\> #\>) (#\q #\') (#\Q #\`) (#\\ #\\)
		       (#\t (setq nonascii t) (int-char 9))
		       (#\x (setq nonascii t)
			(let ((d1 (read-char f))
			      (d2 (read-char f))
			      )
			  (read-char f) ;; skip trailing blank
			  (int-char (+ (* 16 (hex-digit d1))
				       (hex-digit d2) ))
			  ))
		       )
	       c) ) )
	   )

	  (do ()
	      ((eq (peek-char nil f) #\'))
	      (let ((cell (cons (read-mif-char f) nil))
		    )
		(if ex (setf (cdr ex) cell) (setf ret cell))
		(setf ex cell)))
	  (read-char f) ; toss the trailing #\'
	  (cons (concatenate (if nonascii 'cons 'string) ret) NIL)
	  ) )

(defun read-mif-inset (f c &aux ex ret)
  ;; a mif inset looks like:
  ;; =FrameImage
  ;; &lksjdflskdjflsdkj
  ;; &lksdjflsdkjflsdkjf
  ;; =EndInset
  ;;
  (setf ret (setf ex (cons (read f) nil))) ;; read =symbol
  (do ()
      ((not (eq (peek-char t f) #\&)))
      (read-char f) ;; skip &
      (let ((cell (cons (read-line f) nil))
	    )
	(setf (cdr ex) cell)
	(setf ex cell)))
  (cons ret NIL))

(defMethod MifReader :readtable ()
  (or table
      (progn
	(setq table (subseq *readtable* 0))
	(flet ((setchar (c v)
			(setf (aref table (char-int c))
			      v) )
	       )
	      (setchar #\< (cons :tmacro #'read-mif-statement))
	      (setchar #\` (cons :tmacro #'read-mif-string))
	      (setchar #\= (cons :tmacro #'read-mif-inset))
					; # is the MIF comment char
	      (setchar #\# (aref table (char-int #\;)))
					; signal errors on >'s
	      (setchar #\>
		       (cons :tmacro
			     (lambda (f c)
			       (error "misplaced right angle bracket"))) )
					; quote is short for IN, i.e. inch
	      (setchar #\" (cons :tmacro
				 (lambda (f c)
				   (cons 'in nil) ) ))
	      )
	table
	) ) )

(provide 'Mif)