;; init.lsp -- init XLisp global environment
;;

(defun require (package)
  (unless (get package 'provided)
	  (or (load (concatenate 'string (string-downcase package) ".ol"))
	      (load (concatenate 'string (string-downcase package) ".l"))
	      (load (concatenate 'string (string-downcase package) ".lsp"))
	      (error "can't load package" package))
	  ) )

(defun provide (package)
  (setf (get package 'provided) t)
  )


; from 2.1almy...
; initialization file for XLISP 2.0

(unless (fboundp 'strcat) ; backwards compatibility if COMMONLISP defined
	(defmacro strcat (&rest str) `(concatenate 'string ,@str)))


; define some macros
(defmacro defvar (sym &optional val)
  `(if (boundp ',sym) ,sym (setq ,sym ,val)))
(defmacro defparameter (sym val)
  `(setq ,sym ,val))
(defmacro defconstant (sym val)
  `(setq ,sym ,val))

; (makunbound sym) - make a symbol value be unbound
(defun makunbound (sym) (setf (symbol-value sym) '*unbound*) sym)

; (fmakunbound sym) - make a symbol function be unbound
(defun fmakunbound (sym) (setf (symbol-function sym) '*unbound*) sym)

; (mapcan fun list [ list ]...)
(defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))

; (mapcon fun list [ list ]...)
(defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))

; initialize to enable breaks and trace back
(setq *breakenable* t)
(setq *tracenable* nil)
(alloc 50000)
;; functions missing that are part of common lisp, and commonly used

;; push and pop treat variable v as a stack

(defmacro push (v l)
	`(setf ,l (cons ,v ,l)))

(defmacro pop (l)
	`(prog1 (first ,l) (setf ,l (rest ,l))))

;; pairlis does not check for lengths of keys and values being unequal

(defun pairlis (keys values list)
    (do ((remkeys keys (rest remkeys))
	 (remvals values (rest remvals))
	 (newalist list
		   (cons (cons (first remkeys) (first remvals)) newalist)))
	((null remkeys) newalist)
     ))


(defun copy-list (list) (append list 'nil))

(defun copy-alist (list)
    (if (null list)
        'NIL
        (cons (if (consp (car list))
		  (cons (caar list) (cdar list))
		  (car list))
	      (my-copy-alist (cdr list)))))

(defun copy-tree (list)
    (if (consp list)
        (cons (copy-tree (car list)) (copy-tree (cdr list)))
        list))

(defun list* (&rest list)
    (cond ((null list) 'nil)
	  ((null (cdr list)) (car list))
	  (t (do* ((head (cons (car list) 'nil))
		   (current head
			    (cdr (rplacd current (cons (car tail) 'nil))))
		   (tail (cdr list) (cdr tail)))
		  ((null (cdr tail)) (rplacd current (car tail)) head)
	      ))))

;; THE CAR OF A TCONC POINTS TO THE TCONC LIST,
;; THE TAIL POINTS TO LAST ELEMENT

(defun make-tconc nil
    (cons 'nil 'nil))

(defun tconc (tc new)
    (let ((newl (cons new 'nil)))
      (if (null (cdr tc))
	  (rplaca tc newl)
	  (rplacd (cdr tc) newl))
      (rplacd tc newl)
      tc))

(defun lconc (tc list)
    (cond ((not (null list))
	   (if (null (cdr tc))
	       (rplaca tc list)
	       (rplacd (cdr tc) list))
	   (rplacd tc (last list))))
    tc)

(defun remove-head (tc)
    (cond ((null (car tc)) 'nil)
	  ((null (cdar tc))
	   (let ((element (caar tc)))
	     (rplaca tc 'nil)
	     (rplacd tc 'nil)
	     element))
	  (t (let ((element (caar tc)))
	       (rplaca tc (cdar tc))
	       element))))

(provide 'common)
;; objective-lisp.l -- syntactic extensions to XLisp for OOP
;;

;
; extend reader syntax so that [obj args...]
; reads as (send obj args...)
;

(setf (aref *readtable* (char-int #\[)) ; #\[ table entry
      (cons :tmacro
	    (lambda (f c &aux ex ret)	; second arg is not used
	      (do ()
		  ((eq (non-comment-char f) #\]))
		  (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 (cons 'send ret) NIL))
	    ))

(setf (aref *readtable* (char-int #\]))
      (cons :tmacro
	    (lambda (f c)
	      (error "misplaced right bracket"))))


(defun non-comment-char (f)
  (do ((c (peek-char t f) (peek-char t f))
       )
      ((not (eq (aref *readtable* (char-int c))
		(aref *readtable* (char-int #\;))))
       c)
      (read-line f)
      ) )


;
; defclass, defmethod forms
;

;
; (defmethod _class_ :selector (args) body...)
; adds a method to _class_
;
(defmacro defMethod (cls message arglist &rest body)
  `[,cls :answer ',message ',arglist
	 ',body]
  )

(defMethod Class :SET-PNAME (NAME)
  (SETF PNAME (STRING NAME))
  )

;
; (defClassMethod _class_ :selector (args) body...)
; adds a method to _class_'s metaclass.
;
(defmacro defClassMethod (cls message arglist &rest body)
  `[[,cls :class] :answer ,message ',arglist
    ',body]
  )

;
; In order to have class methods, every normal class
; is an instance of a metaclass. All the metaclasses
; are instances of class.
;

;
; Create the root of the metaclass hierarchy
;

(setf MetaClass [Class :new () () Class])
[MetaClass :set-pname 'MetaClass]

(defMethod Class :for (name super)
  (let ((mc [MetaClass :new () () [super :class]])
	)
    [mc :set-pname (concatenate 'string (string name) "-MetaClass")]
    mc
    ) )

;
; Create a class and its metaclass.
;

(defmacro defClass (cl super &optional ivars cvars)
  (if (null super) (setq super 'Object))
  `(let ((mc [MetaClass :for ',cl ,super])
	 )
     (setf ,cl [mc :new ',ivars ',cvars ,super])
     [,cl :set-pname ',cl]
     )
  )

(provide 'objective-lisp)
;; stream.ol

(require 'objective-lisp)

(defClass Stream ()
  (stream)
  )

(defMethod Stream :isnew (s)
  (setf stream s)
  self
  )

(defClass IStream Stream
  ()
  (common-lisp-read-table)
  ;; *readtable* is a class variable of IStream
  )

(defMethod IStream :isnew (s)
  (send-super :isnew s)
  (unless common-lisp-read-table
	  (setq common-lisp-read-table *readtable*)) ;;HACK
  self
  )

(defClassMethod IStream :open (fn)
  [self :new (open fn)]
  )

(defMethod IStream :set-readtable (&optional tbl)
  (setq *readtable* (or tbl common-lisp-read-table))
  )

(defMethod IStream :read (&optional eof)
  (read stream eof)
  )

(defClass OStream Stream
  ()
  )

(defMethod OStream :format (form &rest args)
  (apply #'format (append (list stream form) args))
  )

(provide 'stream)
;;; sgml.ol -- objective lisp interface to SGML
;;; $Id$
;;;

(require 'Stream)

(defClass SGML OStream
  (gi-stack)
  )

(defMethod SGML :empty (gi &optional attrs)
  [self :format "<~A" gi]
  (dolist (a attrs)
	  (let ((n (first a))
		(v (second a))
		)
	    [self :format " ~A=\"~A\"" n v])
	  )
  [self :format ">"]
  )

(defMethod SGML :start (gi &optional attrs)
  (push gi gi-stack)
  [self :empty gi attrs]
  )

(defMethod SGML :end (gi)
  (unless (eq gi (pop gi-stack))
	  (error "gi mismatch on" gi))
  [self :format "</~A>" gi]
  )

(defMethod SGML :ndata (data)
  ;;@@ watch out for markup (</) in ndata!
  [self :format "~A" data]
  )

(defMethod SGML :end-record ()
  [self :format "~%"]
  )

(defMethod SGML :pcdata (data)
  ;;@@ watch out for markup (<, &) in ndata!
  [self :format "~A" 
	(case (type-of data)
	      (string data)
	      (nil "")
	      (cons (concatenate 'string data))
	      (t (error "unknown pcdata representation:" data))
	      )]
  )

(defMethod SGML :doctype (gi)
  ;;@@ entities etc.
  ;;@@ public DTD's
  [self :format "<!DOCTYPE ~A SYSTEM>~%" gi]
  )

(provide 'sgml)
;; 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)
;; mifrw.l -- convert Frame MIF
;;
;; $Id: mifrw.ol,v 1.1 92/08/19 18:37:59 connolly Exp $
;;
;; @@ marks hacks, kludges, and broken code
;; @# marks heuristics and approximations
;;

(require 'common)
(require 'objective-lisp)
(require 'mif)

(defMethod MIFReader :load (m)
  (do ((statement [self :read] [self :read])
       )
      ((null statement)
       )

      (format *trace-output* "~A "  (first statement))

      [m (first statement) statement]
      )
  )

(defMethod MIF MIFFile (statement) )
(defMethod MIF Comment (statement) )
(defMethod MIF Units (statement) )
(defMethod MIF Verbose (statement) )
(defMethod Mif ConditionCatalog (statement)  )
;(defMethod MIF PgfCatalog (statement) )
;(defMethod MIF FontCatalog (statement) )
(defMethod Mif TblCatalog (statement)  )
(defMethod Mif RulingCatalog (statement)  )
;(defMethod Mif VariableFormats (statement) )
;(defMethod Mif XRefFormats (statement) )
(defMethod Mif Document (statement)  )
(defMethod Mif BookComponent (statement)  )
(defMethod Mif Dictionary (statement)  )
;(defMethod Mif AFrames (statement) )
(defMethod Mif Tbls (statement)  )
(defMethod MIF Page (statement) )
(defMethod MIF TextFlow (statement) )


(defClass Catalog ()
  (entries)
  )

(defMethod Catalog :enter (key val)
  (push (cons key val) entries)
  )

(defMethod Catalog :lookup (key)
  (cdr (assoc key entries))
  )

(defMethod MIF PgfCatalog (statement)
  (setq PgfCatalog [Catalog :new])
  (dolist (entry (rest statement))
	  [PgfCatalog :enter (get-name '(PgfTag) entry) entry]
	  )
  )

(defMethod MIF FontCatalog (statement)
  (setq FontCatalog [Catalog :new])
  (dolist (entry (rest statement))
	  [FontCatalog :enter (get-name '(FTag) entry) entry]
	  )
  )

(defMethod Mif VariableFormats (statement) 
  (setq VariableFormats [Catalog :new])
  (dolist (format (rest statement))
	  (let ((name (get-name '(VariableName) format))
		(def (get-data '(VariableDef) format))
		)
	    [VariableFormats :enter name def]
	    ) )
  )

(defMethod Mif XRefFormats (statement)
  (setq XRefFormats [Catalog :new])
  (dolist (format (rest statement))
	  (let ((name (get-name '(XRefName) format))
		(def (get-data '(XRefDef) format))
		)
	    [XRefFormats :enter name def]
	    ) )
  )
	    
(defMethod Mif AFrames (statement)
  (setq AFrames [Catalog :new])
  (dolist (entry (rest statement))
	  [AFrames :enter (get-data '(ID) entry) entry]
	  )
  )
   
;;;;;;;;;;;;;
;; utlities

(defun find-data (tokens statements)
  ;; example: (find-data '(Para ParaLine TextRectID) (rest textflow))
  ;;   will find the first Para statement in the textflow,
  ;;        find the first ParaLine statement in the para,
  ;;        and find the first TextRectID therein.
  ;;        returns the rest of the TextRectID statemnt, e.g.: (12)
  (if (null tokens) statements
    (do* ((target (first tokens))
	  (s statements (rest s))
	 )
	((null s) nil)
	(let ((candidate (first (first s)) (first (first s)))
	      (result (rest (first s)) (rest (first s)))
	      )
	  (if (eq candidate target)
	      (return (find-data (rest tokens) result)) )
	  )
	) ) )

(defun get-data (tokens statement)
  (first (find-data tokens (rest statement)))
  )

(defun get-name (tokens statement)
  (let ((s (get-data tokens statement))
	)
    (cond ((equal s "") nil)
	  (s (intern s))
	  )
    )
  )

(defun find-statements (token statement)
  (remove-if-not #'(lambda (s)
		     (eq token (first s))
		     )
		 (rest statement))
  )

(defun twips (measure)
  (if (consp measure)
      (let ((n (first measure))
	    (u (and (rest measure) (second measure)))
	    )
	(truncate (* n (case u
			     (in 1440)
			     (pt 20)
			     (cm (* 1440 2.54))
			     (pica (/ 1440 12))
			     ))) )
    0) )


;;;;;;;;;;;;;;;;;;;;
;; special MIF routines
;; that maintain state for RTF routines
;; (should be subclass)
;;

(defMethod MIF Page (statement)
  (or MasterPages (setq MasterPages [Catalog :new])) ;; should be in :isnew
  (let ((type (get-data '(PageType) statement))
	(tag (get-name '(PageTag) statement))
	)
    (case type
	  (BodyPage (push statement body))
	  ((LeftMasterPage RightMasterPage OtherMasterPage)
	   [MasterPages :enter tag statement] )
	  ;; @# ReferencePage, HiddenPage
	  ) )
  )

(defMethod MIF :body-pages ()
  (reverse body)
  )

(defMethod MIF TextFlow (statement)
  (or TextFlows (setq TextFlows [Catalog :new])) ;; should be in :isnew
  [TextFlows :enter (get-data '(Para ParaLine TextRectID) statement) statement]
  )

(defMethod Mif :write-pages ()
  (dolist (page [self :body-pages])
	  [self :write-frame 
		[MasterPages :lookup (get-name '(PageBackground) page)]]
	  ;; no output unless there's something there!
	  (when [self :write-frame page]
		[out :end-section]
		(format *trace-output* "!~%" )
		)
	  ) )

(defMethod MIF :write-frame (frame &aux output)
  ;;@@ sort objects by brect?
  (dolist (object (rest frame))
	  (case (first object)
		(Frame [self :write-frame object])
		;;@@(TextLine [self :write-textline object])
		(ImportObject
		   [self :write-image object (get-data '(AnchorAlign) frame)] )
		(TextRect
		 (let* ((id (get-data '(id) object))
			(flow [TextFlows :lookup id])
			(tag (get-data '(tftag) flow))
			)
		   (when flow
			 [self :write-textflow flow]
			 (setq output t)
			 )
		   ) )
		) )
  output
  )

(defMethod  MIF :write-image (image &optional align)
  (let ((image (find-data '(FrameImage) (rest image)))
	)
    (and image [out :raster 'MifVec image align])
    ) )

(defMethod MIF :write-textflow (textflow)
  ;;@@footnotes
  ;;@@(setq hyper nil)
  (dolist (s (rest textflow))
	  (case (first s)
		(Para [self :write-para s])
		) )
  )

(defMethod MIF :write-para (para)
  ;; AFrames and Tbls before the paragraph
  [self :write-floats para '(Top Left Near)]
  
  (let* ((local-format (find-data '(Pgf) (rest para)))
	 (tag (get-name '(PgfTag) para))
	 (tag-format (and tag [PgfCatalog :lookup tag]))
	 (pgfnumstring (get-data '(PgfNumString) para))
	 (pgfnumberfont (or (get-name '(PgfNumberFont) local-format)
			    (and tag (get-name '(PgfNumberFont)
					       tag-format)) ))
	 )

    (when tag
	  [out :reset-paragraph-format tag tag-format]
	  [out :reset-character-format nil (get-data '(PgfFont) tag-format)]
	  )

    (when local-format
	  [out :change-paragraph-format local-format]
	  [out :change-character-format (get-data '(PgfFont) local-format)] )

    (when pgfnumstring
	  [out :save-character-format]
	  (if pgfnumberfont
	      [out :reset-character-format
		   pgfnumberfont
		   [FontCatalog :lookup pgfnumberfont]])
	  [out :pcdata pgfnumstring] ;; @@character set translation
	  [out :restore-character-format])
    )
  
  ;; Elements of the para
  (dolist (paraline (rest para))
	  (case (first paraline)
		(ParaLine
		 ;;@@ HACK! RTF widget doesn't do blank lines right!
		 (when (null (rest paraline))
		       [out :pcdata " "] )
		 
		 (dolist (s (rest paraline))
			 (case (first s)
			       ((Font PgfFont)
				;;@@[self :end-hyper]
				[out :change-character-format s] )
			       (String [out :pcdata (second s)]
				       ;;@@[self :hyper-not-empty]
				       )
			       (Char
				(case (second s)
				      (Tab [out :tab])
				      (HardSpace [out :pcdata " "]) ;;@@
				      (HardReturn [out :newline])
				      (t (ignore s)) ) )
			       (FNote (ignore s)) ;;@@
			       (Marker [out :marker
					    (get-data '(MType) s)
					    (get-data '(MText) s)])
			       (Variable
				[out :ndata
				     [VariableFormats :lookup
						      (get-name '(VariableName)
								v)]] )
			       ;;@@(XRef)
			       ) )
		 [out :end-record]
		 ) )
	  )
  
  ;;@@[self :end-hyper]
  [out :end-paragraph]
  (princ "." *trace-output*)
  
  ;; AFrames and tables after the para
  [self :write-floats para '(Inline Below Bottom Right Far)]
  )

(defMethod MIF :write-floats (para places)
  (dolist (paraline (rest para))
	  (when (eq (first paraline) 'ParaLine)
		(dolist (s (rest paraline))
			(case (first s)
			      (AFrame
			       (let* ((id (second s))
				      (frame [AFrames :lookup id])
				      (placement (get-data '(FrameType) frame))
				      )
				 (if (member placement places)
				     [self :write-frame frame])
				 ) ) ) ) ) ) )

;;;;;;;;;;;
;; methods with explicit RTF knowledge
;;

(defun format-marker (stream m)
  (let ((type (get-data '(MType) m))
	(text (get-data '(MText) m))
	)
    (case type
	  ;;@# 0, 1, 3, 4, 5, 6, 7
	  (2 (format stream "{\\v{\\xe ")
	     (format-string stream text)
	     (format stream "}}")
	     )
	  (8 (format stream "{\\field{\\fldrslt ")
	     (setq *HyperLink* (list nil text))
	     )
	  )
    ) )

(defun ignore (s)
  (pprint s *error-output*)
  )

(provide 'mifrw)
;;; html.ol -- objective lisp support for the WWW HTML format
;;; $Id: html.ol,v 1.1 92/08/19 18:37:59 connolly Exp $
;;;

(require 'SGML)

(defClass HTML SGML
  (ignore anchor-content)
  )

(defMethod HTML :pcdata (data)
  (or ignore (send-super :pcdata data))
  (setq anchor-content t)
  )

(defMethod HTML :end-record ()
  ;; nothing
  )

(defMethod HTML :isnew (stream)
  (send-super :isnew stream)
  [self :doctype 'HTML]
  )

(defMethod HTML :started (gi)
  (or (member gi gi-stack)
      [self :start gi])
  )

(defMethod HTML :ended (gi)
  (do ()
      ((null (member gi gi-stack)))
      [self :end (first gi-stack)]
      (send-super :end-record)
      ) )

(defMethod HTML :restore (gi)
  (do ()
      ((eq gi (first gi-stack)))
      [self :end (first gi-stack)]
      (send-super :end-record)
      ) )

(defMethod HTML :reset-paragraph-format (tag fmt)
  (if (eq tag 'TITLE)
      [self :started tag]
    (unless (eq tag (first gi-stack))
	    [self :started 'document]
	    [self :restore 'document]
	    [self :started tag]))
  (case tag
	((DIR MENU OL UL)
	 [self :empty 'LI])
	(DL
	 [self :empty 'DT]
	 )
  ) )

(defMethod HTML :reset-character-format (tag foo)
  [self :end-anchor]
  )
(defMethod HTML :change-paragraph-format (foo)
  )
(defMethod HTML :change-character-format (foo)
  [self :end-anchor]
  )
(defMethod HTML :save-character-format ()
  (setq ignore t)
  )
(defMethod HTML :restore-character-format ()
  (setq ignore nil)
  )

(defMethod HTML :end-paragraph ()
  [self :end-anchor]
  (case (first gi-stack)
	
	(document
	 [self :empty 'P]
	 (send-super :end-record))
	((ul ol dir menu dl)
	 ;;nothing
	 )
	(t [self :end (first gi-stack)]
	   (send-super :end-record))
  ))

(defMethod HTML :end-section ()
  [self :ended 'DOCUMENT]
  )

(defMethod HTML :tab ()
  [self :end-anchor]
  (case (first gi-stack)
	(DL
	 [self :empty 'DD]
	 )
	) )

(defMethod HTML :newline ()
  (case (first gi-stack)
	((XMP LISTING)
	 (send-super :end-record)
	 )
	) )

(defMethod HTML :start-anchor (name href &aux attrs)
  (if name (push `(name ,name) attrs))
  (if href (push `(href ,href) attrs))
  [self :start 'a attrs]
  (setq anchor-content nil)
  )

(defMethod HTML :end-anchor ()
  (if anchor-content [self :ended 'a])
  )

(defMethod HTML :marker (type text)
  (case type
	(8 (let* ((str (make-string-input-stream text))
		  (command (read str))
		  )
	     (case command
		   (newlink (peek-char t str)
			    [self :start-anchor (read-line str) nil])
		   (gotolink [self :start-anchor nil (read-href str)])
		   (message (let ((client (read str))
				  )
			      (peek-char t str) ;; skip whitespace
			      (case client
				    (www [self :start-anchor nil
					       (read-line str)] )
				    ) ))
		   )
	     ))
	) )

(defun read-href (str)
  ;; parse foo:bar -> file:foo#bar
  ;;       bar -> #bar
  ;;       foo:firstpage -> file:foo
  (peek-char t str)
  (do (file
       anchor ex
       href
       (char (read-char str) (read-char str))
       )
      ((null char) ;; reached end of string
       (if file
	   (setq href (concatenate 'string "file:" file)) )
       (cond ((null anchor) )
	     ((eq 'firstpage (intern (concatenate 'string anchor))) )
	     (t (setq href (concatenate 'string href "#"
					anchor) )) )
       href
       )
      
      ;; body of do loop...
      (case char
	    (#\: (setq file anchor)
	     (setq anchor nil)
	     (setq ex nil) )
	    (t (let ((cell (cons char nil))
		     )
		 (if ex (setf (cdr ex) cell)
		   (setf anchor cell) )
		 (setf ex cell) ))
	    )
      ) )

(provide 'html)
;; mif2html.ol -- convert Frame interchange format to HTML
(require 'mifrw)
(require 'html)

(setq x [MifReader :new *standard-input*])
(setq z [HTML :new *standard-output*])
(setq y [MIF :new z])
[x :load y]
[y :write-pages]

(exit)