;;; -*- Mode:Common-Lisp; Package:Doc; Base:10; Fonts:(CPTFONT HL12 HL12BI CPTFONTB CPTFONTI) -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1987-1989 Texas Instruments Incorporated. All rights reserved.


Ï1;;;Ï*	Ï2Cross-reference and documentation utilityÏ* 

Ï1;Version:
;  7/22/87 DNG - Original.
;  7/28/87 DNG - Add documentation for formatter operations.
;  7/31/87 DNG - Fixed Ï*PRINC-QUOTEÏ1 to not error on dotted lists and to include colon on keywords.
;  9/11/87 DNG - Modified Ï*print-header-lineÏ1 to allow pathname to be a string.
;  9/14/87 DNG - Fixed to not choke on a function name containing a tilde.
;  1/03/89 DNG - Added Ï*LaTeX-formatterÏ1 [but not tested yet].
;  1/16/89 DNG - ModifiedÏ* print-doc-string Ï1to not error if value is not a string.
;  1/20/89 DNG - Define a "Document" command for Zmacs.  Add support for 
;Ï*		Ï1mousable items when writing to Zmacs type-out window.

;;;Ï*	Ï1Output formattingÏ*

(defparameter *line-length* 70.
  Ï1"Number of characters on a line of the document, not counting margins."Ï*)

(defvar *margin* 5 Ï1"number of characters in left margin"Ï*)
(defparameter *indent* 5 Ï1"number of characters to indent continuation lines"Ï*)

(defun print-header-line (name kind pathname)
  (let* ((*line-length* (send *formatter* :line-length))
	 (line (make-array *line-length* :element-type 'string-char :fill-pointer 0))
	 (name-string (if (and (symbolp name)
			       (eq (symbol-package name) *package*))
			  (symbol-name name)
			(format nil "~S" name))))
    (send *formatter* :skip-line)
    (if (> (length name-string) *line-length*)
	(send *formatter* :as-is-line name-string)
      (format line "~A" name-string))
    (unless (null kind)
      (let* ((kind-string (string kind)))
	(when (>= (+ (length line) 2 (length kind-string)) *line-length*)
	  (send *formatter* :as-is-line line)
	  (setf (fill-pointer line) 0))
	(dotimes (i (max 2 (- 30 (length line))))
	  (vector-push-extend #\space line))
	(format line kind-string)))
    (when pathname
      (let* ((path-string (if (stringp pathname) pathname
			    (format nil "\"~A;~A\""
				    (car (last (send pathname :directory)))
				    (send pathname :name))))
	     (path-length (length path-string)))
	(when (>= (+ (length line) 2 path-length) *line-length*)
	  (send *formatter* :as-is-line line)
	  (setf (fill-pointer line) 0))
	(dotimes (i (max 2 (- (min 50 (- *line-length* path-length))
			      (length line))))
	  (vector-push-extend #\space line))
	(format line path-string)
	))
    (send *formatter* :as-is-line line)
    (values)))

(defun print-labeled-list (label list &optional (print-function #'print-with-escape) (separator ", ")
			   beginning-delimiter ending-delimiter)
  (format t "~2&")
  (dotimes (i *margin*) (write-char #\space))
  (format t "~A: " label)
  (if (and (atom list)
	   (not (and (null list) beginning-delimiter ending-delimiter)))
      (funcall print-function list)
    (progn (when beginning-delimiter (princ beginning-delimiter))
	   (print-list list print-function separator *indent* (+ *margin* 2 (length label)))
	   (when ending-delimiter (princ ending-delimiter))))
  (values))

(defun print-labeled-value (label value &optional (print-function #'prin1))
  (print-labeled-list label value print-function " " (and value "(") ")"))

(defun print-labeled-list-else (label list string-to-print-when-null
				&optional (print-function #'print-with-escape))
  (if (null list)
      (print-labeled-list label string-to-print-when-null #'princ)
    (print-labeled-list label list print-function)))

(defun print-list (list print-function separator indent &optional starting-column)
  Ï1;; Print each element of Ï*LISTÏ1 using Ï*PRINT-FUNCTION,Ï1 indenting Ï*INDENTÏ1 spaces atÏ*
  Ï1;; the beginning of each new line and string Ï*SEPARATORÏ1 between elements.Ï*
  (let ((col (or starting-column (+ *margin* indent)))
	(seplen (print-length separator nil))
	(limit *print-length*))
    (do ((items list (rest items)))
	((atom items)
	 (unless (null items)
	   (format t " . ")
	   (funcall print-function items) ))
      (when (and limit
		 (< (decf limit) 0)
		 (cdr items))
	(format t "...")
	(return))
      (let* ((item (first items))
	     (len (+ (print-length item t) seplen)))
	(when (or (and (eq print-function #'princ-quote)Ï1 ; special hack for arglistsÏ*
		       (member item lambda-list-keywords :test #'eq)
		       (not (eq items list))
		       (cddr items))
		  (let ((column (send *standard-output* :send-if-handles :read-cursorpos :character)))
		    (if column
			(> (+ column len)
			   *line-length*)
		      (> (+ col len) *line-length*))))
	  (fresh-line)
	  (setq col (+ *margin* indent))
	  (dotimes (i col) (write-char #\space)))
	(funcall print-function item)
	(unless (atom (rest items))
	  (format t "~A" separator))
	(incf col len)
	)))
  (values))

(defun print-length (object escapep)
Ï1  ;; estimate the number of characters needed to print this objectÏ*
  (typecase object
    ( string (if escapep
		 (+ (length object) 2)
	       (length object)) )
    ( symbol (let* ((name (symbol-name object))
		    (name-length (length name))
		    (pkg (symbol-package object)))
	       (cond ((not escapep)
		      name-length)
		     ((null pkg)
		      (+ name-length 2))
		     ((eq pkg *keyword-package*)
		      (+ name-length 1))
		     ((or (eq pkg *package*)
			  (eq object (find-symbol name)))
		      name-length)
		     (t (+ name-length
			   (length (package-name pkg))
			   2))Ï1 ; may need two colonsÏ*
		     )) ) 
    ( character (if escapep 3 1) )
    ( cons (let ((count 1))
	     (dolist (element object)
	       (incf count (+ (print-length element escapep) 1)))
	     count) )
    ( integer (if (zerop object)
		  1
		(1+ (truncate (log (abs object) 10.)))))
    ( pathname (print-length (send object :short-string-for-printing) escapep) )
    ( t 30 )))

(defun print-with-escape (object)
  (declare (optimize (speed 2) (safety 0)))
  (prin1 (if (pathnamep object)
	     (send object :short-string-for-printing)
	   object)))

(defun print-doc-string (doc-string)
  (when (stringp doc-string)
    (send *formatter* :new-paragraph)
    (send *formatter* :string-out doc-string)
    ))

(defun print-trailer () ; at end of documentation for one thing
  (send *formatter* :skip-line 1))

(defun princ-quote (list)
  Ï1;; Like Ï*PRINC,Ï1 but use Ï*'Ï1 and Ï*#'Ï1 notation when appropriate, and include quotes on stringsÏ*
  (cond ((atom list)
	 (if (or (stringp list)
		 (characterp list)
		 (keywordp list))
	     (prin1 list)
	   (princ list)))
	((and (eq (car list) 'quote)
	      (= (length list) 2))
	 (write-char #\')
	 (princ (second list))
	 list)
	((and (eq (car list) 'function)
	      (= (length list) 2))
	 (write-string "#'")
	 (princ (second list))
	 list)
	(t (write-char #\()
	   (print-list list #'princ-quote " " *indent*)
	   (write-char #\))
	   list)))

Ï1;;;Ï*	Ï1Mouse handling for Zmacs type-out windowÏ*

(defun print-mousable-caller (object &optional mouse-value)
  ;; object is name of function, file, or special variable
  (declare (optimize (speed 2) (safety 0)))
  (let (kind)
    (if (pathnamep object)
	(let ((string (send object :short-string-for-printing)))
	  (if (send *standard-output* :operation-handled-p :item)
	      (send *standard-output* :item 'zwei:file
		    (or mouse-value
			(fs:generic-pathname-source-pathname object))
		    "~s" string)
	    (prin1 string)))
      (if (and (sys:validate-function-spec object)
	       (send *standard-output* :operation-handled-p :item)
	       (setq kind (cond ((fdefinedp object) 'zwei:function-name)
				((not (symbolp object)) nil)
				((get object 'special) 'symbol)
				;;((get object 'si:flavor) 'zwei:flavor-name)
				)))
	  (send *standard-output* :item kind (or mouse-value object) "~s" object)
	(prin1 object)))))

(defun print-mousable-flavor (object)
  (if (and (symbolp object)
	   (get object 'si:flavor)
	   (send *standard-output* :operation-handled-p :item))
      (send *standard-output* :item 'zwei:flavor-name object "~s" object)
    (prin1 object)))

(defun print-mousable-symbol (object) ; suitable for variables, classes, types, etc.
  (let (kind)
    (if (and (symbolp object)
	     (setq kind (cond ((not (null (symbol-plist object)))
			       (if (and (external-symbol-p object)
					(boundp 'sys:initial-packages)
					(assoc (package-name (symbol-package object))
					Ï1          Ï*sys:initial-packages :test #'equal)
					(si:system-made-p :visidoc))
				   'zwei:function-name Ï1; enable access to VisidocÏ*
				Ï1 Ï*'symbol)Ï1)Ï*
			      ((any-item-p object) 'xref-item)))
	     (send *standard-output* :operation-handled-p :item))
	(send *standard-output* :item kind object "~s" object)
      (prin1 object))))

(defun item-printer (function)
  (if (send *standard-output* :operation-handled-p :item)
      function
    #'print-with-escape))

(defun do-document (name) (document name nil nil t) nil)
(defun do-visidoc (name)
  (zwei:kill-new-buffer-on-abort (zwei:*interval*)
    (zwei:doc-viewer-top-level name)))

(when (boundp 'zwei:*TYPEOUT-COMMAND-ALIST*)
  (let ((name "Document")) Ï1; avoid duplicationÏ*
    (W:ADD-TYPEOUT-ITEM-TYPE zwei:*TYPEOUT-COMMAND-ALIST* FUNCTION-NAME name DO-DOCUMENT ()
			     "Display documentation for this function.")
    
    (when (si:system-made-p :visidoc)
      (W:ADD-TYPEOUT-ITEM-TYPE zwei:*TYPEOUT-COMMAND-ALIST* FUNCTION-NAME "Manual" DO-visidoc ()
			       "Invoke Visidoc to look up this function in the manual.") )
    
    (W:ADD-TYPEOUT-ITEM-TYPE zwei:*TYPEOUT-COMMAND-ALIST* zwei:flavor-name name DO-DOCUMENT ()
			     "Display documentation for this flavor.")
    (when (fboundp 'inspect-flavor)
      (W:ADD-TYPEOUT-ITEM-TYPE zwei:*TYPEOUT-COMMAND-ALIST* zwei:flavor-name "Inspect" inspect-flavor ()
			       "Inspect this flavor."))
    (W:ADD-TYPEOUT-ITEM-TYPE zwei:*TYPEOUT-COMMAND-ALIST* symbol "Edit"
			     zwei:EDIT-DEFINITION-FOR-MOUSE T
			     "Edit the definition of this name.")
    (W:ADD-TYPEOUT-ITEM-TYPE zwei:*TYPEOUT-COMMAND-ALIST* symbol name DO-DOCUMENT ()
			     "Display documentation for this symbol.")
    (W:ADD-TYPEOUT-ITEM-TYPE zwei:*TYPEOUT-COMMAND-ALIST* symbol "Inspect" INSPECT ()
			     "Inspect this symbol.")
    (W:ADD-TYPEOUT-ITEM-TYPE zwei:*TYPEOUT-COMMAND-ALIST* xref-item name DO-DOCUMENT t
			     "Display documentation for this symbol.")
    ))

(when (fboundp 'zwei:bind-key)
  (zwei:DEFCOM COM-DOCUMENT "Display documentation for the specified symbol or function spec.
With a numeric arg, the documentation is inserted into the current buffer.
Call DOC:BUILD-XREF-TABLE first to enable seeing who references the symbol." ()
  ZWEI:
    (let ((name (READ-FUNCTION-NAME "Document" (RELEVANT-FUNCTION-NAME (POINT)) 'nil)))
      (if *NUMERIC-ARG-P*
	  (let ((*standard-output* (INTERVAL-STREAM-INTO-BP (POINT))))
	    (DOC:DOCUMENT name nil nil t)
	    (MOVE-BP (POINT) (SEND *standard-output* :READ-BP))	; set cursor at end of output
	    (let ((*NUMERIC-ARG* -1))
	      (COM-RECENTER-WINDOW)))		; redisplay with cursor at bottom of screen
	(progn (DOC:DOCUMENT name nil nil t)
	       DIS-NONE))))
  (dolist (key '(#\meta-shift-D #\hyper-D #\super-D #\hyper-super-D))
    (let ((current (zwei:command-lookup key zwei:*standard-comtab*)))
      (when (or (eq current 'com-document) Ï1; already installedÏ*
		(null current)) Ï1; key is availableÏ*
	  (zwei:bind-key key 'com-document "Document")
	  (format t "~2&\"Document\" command installed on Zmacs key ~@:C~2%" key)
	  (return)))))

Ï1;;;      Formatter streamsÏ*

(defconstant formatter-operations
	     '(:tyo :string-out :line-out :fresh-line Ï1; standard output stream operationsÏ*
	       :which-operations :operation-handled-p Ï1; standard object inquiriesÏ*
	       :line-lengthÏ1 ; special inquiryÏ*
	Ï1       Ï*  Ï1;; document formatting operations:Ï*
	       :new-line :new-paragraph :skip-line :new-page :insert :new-section
	       :as-is-line :need-lines :separator-line :begin-document :end-document
	       :comment)
Ï1  "Operations supported by formatter streams"Ï*)

Ï1; Formatter stream operations:
;   Ï3:tyoÏ4 characterÏ*Ï*Ï*			Ï1 Write one character.
;   Ï3:string-outÏ4 stringÏ*Ï* [Ï4 startÏ* [Ï4 endÏ* ]]    Write a string.
;   Ï3:fresh-lineÏ*Ï*				Ï1 New line in the word processor input file.
;   Ï3:line-outÏ* Ï4stringÏ* [ Ï4startÏ* [ Ï4endÏ* ]]Ï*	Ï1 Write a string followed by new line in w.p. input.
;   Ï3:line-lengthÏ*Ï*			Ï1 Return the number of characters that can be written to
;Ï*				Ï1 Ï*         Ï1one line (between margins) of the w.p. output file.
;   Ï3:new-lineÏ*Ï*				Ï1 Begin new line in word processor output file.Ï*	
Ï1;   Ï3:new-pageÏ*Ï*				Ï1 Page break in w.p. output.
;   Ï3:new-paragraphÏ*Ï*			Ï1 Begin a new paragraph in w.p. output.
;   Ï3:new-sectionÏ4 title-stringÏ*Ï*Ï*		Ï1 Begin a new section in w.p. output.
;   Ï3:skip-lineÏ* [ Ï4numberÏ* ]Ï*		Ï1 Ï*	Ï1 Skip blank lines (default 1) in w.p. output.
;   Ï3:insertÏ4 functionÏ*Ï* . Ï4argsÏ*Ï*		Ï1 As-is textual insert, apply Ï4functionÏ* to Ï4argsÏ* to 
;Ï*					  Ï1generate the inserted text.
;   Ï3:as-is-lineÏ4 format-stringÏ*Ï* . Ï4format-argsÏ*  
;Ï*					Ï1 Write one line verbatim to w.p. output.
;   Ï3:need-linesÏ4 numberÏ*Ï*Ï*			Ï1 Start new page in w.p. output if fewer than Ï4numberÏ* 
;Ï*					Ï1   lines remain on the current page.
;   Ï3:separator-lineÏ*Ï*			Ï1 Write a horizontal line across the page in the w.p. output.
;   Ï3:begin-documentÏ4 kind nameÏ*Ï* [Ï4objectÏ*]Ï*	Ï1 Initialize word processor and build document title 
;Ï*					Ï1   from Ï4kindÏ* and Ï4name.Ï*  Edit Ï4objectÏ* if Ï4nameÏ* is moused.
;   Ï3:end-documentÏ*Ï*			Ï1 Marks end of word processor input.
;   Ï3:commentÏ4 format-stringÏ*Ï* . Ï4format-argsÏ* Ï* Ï1Write a comment line to the w.p. input; won't appear in w.p. output.Ï*

(defun default-formatter (op &rest args)
  (case op
    (:which-operations formatter-operations)
    (:operation-handled-p (and (member (first args) formatter-operations :test #'eq) t))
    ((:force-output :finish :close :eof) (lexpr-send *standard-output* op args))
    (:direction ':output)
    (:characters t)
    (t (error "~S is not a valid formatter operation." op))))

(defvar *item-count* 0)
(defun text-formatter (op &rest args)
  Ï1;; basic output for direct viewingÏ*
  (case op
    (:tyo (return-from text-formatter
	    (send *standard-output* :tyo (first args))))
    ((:string-out :line-out) (lexpr-send *standard-output* op args) (incf *item-count*))
    ((:new-line :fresh-line) (fresh-line))
    (:new-paragraph (format t "~2&   ") (incf *item-count*))
    (:skip-line (format t "~&~V%" (or (first args) 1)) (incf *item-count*))
    (:new-page (format t "~|") (setq *item-count* 0))
    (:insert (fresh-line)
	     (let ((*margin* 5))
	       (apply (first args) (rest args)))
	     (fresh-line)
	     (incf *item-count*))
    (:new-section (ignore (first args))
		  (if (> *item-count* 20)
		      (text-formatter :new-page)
		    (text-formatter :new-line)))
    (:as-is-line (format t "~&  ")
		 (format-t-args args)
		 (fresh-line))
    (:need-lines (when (> (first args) 30) (text-formatter :new-page)))
    (:separator-line
     (format t "~&  -----------------------------------------------------------------------~&")
     (incf *item-count*))
    (:begin-document
Ï1       Ï*(format t "~2&      Documentation for ~A " (first args))
     (if (and (third args)
	      (send *standard-output* :operation-handled-p :item)
	      (sys:validate-function-spec (third args)))
	 (send *standard-output* :item (if (fdefinedp (third args)) 'zwei:function-name 'symbol)
	       (third args) "~A" (second args))
       (format t "~A ~60T~\\datime\\" (or (second args) "")))
     (format t "~&      =======================================================================~%")
     (setq *item-count* 0)
     )
    (:end-document nil)
    (:comment nil)
    (:line-length
     (return-from text-formatter
       (min (line-length *standard-output*) 70))) Ï1; number of characters per lineÏ*
    (t (return-from text-formatter (apply #'default-formatter op args)))
    )
  (values))

(defun format-t-args (args)
  (if (rest args) ; first arg must be a format string
      (apply #'format t args)
    ;; else do it this way in case the string happens to contain a ~ which is not intended as a format directive.
    (format t "~A" (first args))))

(let ((column 0)
      (line-break t))
 (defun PDWS-formatter (op &rest args)
  Ï1;; format document for processing by PDWS Ï*
  (case op
    (:tyo
     (setq line-break nil)
     (let ((char (first args)))
       (block tyo
	 (case char
	   (#\space (when (>= column 60)
		      (fresh-line)
		      (setq column 0)))
	   (#\/ (when (zerop column) (write-char #\space)))
	   ((#\' #\+ #\$ #\^) (write-char #\$))
	   (#\` (setq char #\@) (write-char #\$))
	   (#\{ (setq char #\[) (write-char #\$))
	   (#\} (setq char #\]) (write-char #\$))
	   (#\not-sign (setq char #\~) (write-char #\$))
	   (#\plus-minus (setq char #\#) (write-char #\$))
	   (#\­ (setq char #\/) (write-char #\$))
	   (#\² (setq char #\<) (write-char #\$))
	   (#\³ (setq char #\>) (write-char #\$))
	   (#\Å (format t "~&/ {_=}") (setq char nil))
	   (#\center-dot (setq char #\.))
	   (#\page (format t "~&/pb")
		   (setq line-break t)
		   (setq char #\newline))
	   (#\tab (loop until (zerop (mod column 8))
			do (progn (write-char #\^)
				  (incf column)))
		  (return-from tyo))
	   (#\newline)
	   (#\no-break-space (setq char #\^))
	   (t (let ((name (char-name char)))
		(when name
		  (format t "~&/ {_~A} " (string-downcase name))
		  (setq column (+ (length name) 6))
		  (return-from tyo))))
	   )
	 (unless (null char)
	   (write-char char))
	 (setq column
	       (if (eql char #\newline)
		   0
		 (+ column 1)))
	 ) Ï1; end block Ï*tyo
       (return-from pdws-formatter (char-int char))
       ))
    (:new-line (unless line-break
		 (format t "~&/lb ")
		 (setq column 0)
		 (setq line-break t)))
    (:fresh-line (fresh-line) (setq column 0))
    (:new-paragraph (format t "~&/p~%") (setq column 0) (setq line-break t))
    (:skip-line (format t "~&/s ~D~%" (or (first args) 1))
		(setq column 0) (setq line-break t))
    (:new-page (pdws-formatter :new-line)
	       (format t "~&/reserve block 20~%"))
    ((:string-out :line-out)
     (let ((string (first args)))
       (do ((i (or (second args) 0) (1+ i)))
	   ((>= i (or (third args) (length string))))
	 (pdws-formatter :tyo (char string i))))
     (when (eq op :line-out)
       (pdws-formatter :tyo #\newline)))

    (:insert (format t "~&/begin margined insert~%")
	     (let ((*formatter* #'text-formatter)
		   (*margin* 0)
		   (*line-length* (pdws-formatter :line-length)))
	       (apply (first args) (rest args)))
	     (format t "~&/end insert~%")
	     (setq column 0)
	     (setq line-break t))
    (:new-section (format t "~&/reserve block 12~%/p1(")
		  (setq column 6)
		  (pdws-formatter :string-out (first args))
		  (format t ")~%")
		  (setq column 0)
		  (setq line-break t))
    (:as-is-line (format t "~&/alb ")
		 (let ((*formatter* #'text-formatter))
		   (format-t-args args))
		 (fresh-line)
		 (setq column 0)
		 (setq line-break t))
    (:need-lines (format t "~&/reserve block ~D~%" (first args)))
    (:separator-line
     (format t "~&/c(-----------------------------------------------------------------------)~%")
     (setq column 0)
     (setq line-break t))
    (:begin-document
     (format t "~&/begin~%/date(~\\datime\\)~%/title(Documentation for ~A ~A)~%"
	     (first args) (or (second args) ""))
     (format t "/document(~A ~A)~%"
	     (first args) (or (second args) ""))
     (setq column 0) (setq line-break t)
     )
    (:end-document (format t "~&/end~%"))
    (:comment  (format t "~&/comment  ")
	       (let ((*formatter* #'text-formatter))
		 (format-t-args args))
	       (fresh-line))
    (:line-length (return-from pdws-formatter 66.)) Ï1; number of characters between default marginsÏ*
    (t (return-from pdws-formatter (apply #'default-formatter op args)))
    )
  (values)))

(let ((column 0)
      (line-break t))
 (defun Scribe-formatter (op &rest args)
   Ï1;; format document for processing by ScribeÏ*
   Ï1;; This initial version is rather crude and needs refinement later.Ï*
  (case op
    (:tyo
     (setq line-break nil)
     (let ((char (first args)))
       (block tyo
	 (case char
	   (#\space (when (>= column 90)
		      (fresh-line)
		      (setq column 0)))
	   (#\@ (write-char #\@))
	   (#\page (format t "~&@Newpage")
		   (setq line-break t)
		   (setq char #\newline))
	   (#\tab (loop until (zerop (mod column 8))
			do (progn (write-string "@ ")
				  (incf column)))
		  (return-from tyo))
	   (#\newline
	    (when (zerop column) (setq char nil)))
	   (#\no-break-space (setq char #\space) (write-char #\@))
	   (t nil)
	   )
	 (unless (null char)
	   (write-char char))
	 (setq column
	       (if (eql char #\newline)
		   0
		 (+ column 1)))
	 ) Ï1; end block Ï*tyo
       (return-from Scribe-formatter (char-int char))
       ))
    (:new-line (unless line-break
		 (format t " @* ")
		 (setq column 0)
		 (setq line-break t)))
    (:fresh-line (fresh-line) (setq column 0))
    (:new-paragraph (format t "~&~%") (setq column 0) (setq line-break t))
    (:skip-line (unless (eq line-break 'hinge) (format t "~&~%"))
		(when (first args)
		  (dotimes (i (- (first args) 1))
		    (format t " @ @* ")))
		(setq column 0) (setq line-break t))
    (:new-page (format t "~&@Newpage~&"))
    ((:string-out :line-out)
     (let ((string (first args)))
       (do ((i (or (second args) 0) (1+ i)))
	   ((>= i (or (third args) (length string))))
	 (Scribe-formatter :tyo (char string i))))
     (when (eq op :line-out)
       (Scribe-formatter :tyo #\newline)))

    (:insert (format t "~&@begin[format]~%")
	     (let ((*formatter* #'Scribe-insert)
		   (*margin* 0)
		   (*line-length* (Scribe-formatter :line-length)))
	       (apply (first args) (rest args)))
	     (format t "~&@end[format]~%")
	     (setq column 0)
	     (setq line-break t))
    (:new-section (format t "~&@Heading[")
		  (setq column 6)
		  (Scribe-formatter :string-out (first args))
		  (format t "]~%")
		  (setq column 0)
		  (setq line-break t))
    (:as-is-line (format t "~&@Verbatim[")
		 (let ((*formatter* #'Scribe-formatter))
		   (format-t-args args))
		 (format t "]~&")
		 (fresh-line)
		 (setq column 0)
		 (setq line-break t))
    (:need-lines (format t "~&@Hinge~&") (ignore (first args))
		 (setq column 0) (setq line-break 'hinge))
    (:separator-line
     (format t "~&@Center[------------------------------------------------------------------]~%")
     (setq column 0)
     (setq line-break t))
    (:begin-document
     (format t "~&@MajorHeading[Documentation for ~A ~A]~%@FlushRight[~\\datime\\]~%"
	     (first args) (or (second args) ""))
     (setq column 0) (setq line-break t)
     )
    (:end-document nil)
    (:comment  (format t "~&@Comment[ ")
	       (let ((*formatter* #'text-formatter))
		 (format-t-args args))
	       (format t " ]~%"))
    (:line-length (return-from Scribe-formatter 66.)) Ï1; number of characters between default marginsÏ*
    (t (return-from Scribe-formatter (apply #'default-formatter op args)))
    )
  (values)))

(defun Scribe-insert (op &rest args)
  Ï1;; format verbatim insert for processing by Scribe Ï*
  (case op
    (:tyo
     (let ((char (first args)))
       (block tyo
	 (case char
	   (#\@ (write-char #\@))
	   (#\page (Scribe-formatter :new-page)
		   (return-from tyo))
	   (t nil))
	 (send *standard-output* op char)
	 )
       (return-from Scribe-insert (char-int char)) ))
    ((:string-out :line-out)
     (let ((string (first args)))
       (do ((i (or (second args) 0) (1+ i)))
	   ((>= i (or (third args) (length string))))
	 (Scribe-insert :tyo (char string i))))
     (when (eq op :line-out)
       (Scribe-insert :tyo #\newline)))
    (:comment (apply #'Scribe-formatter args))
    (:line-length (return-from Scribe-insert
		    (Scribe-formatter op)))
    (t (return-from Scribe-insert (apply #'text-formatter op args))) )
  (values))

(let ((column 0)
      (line-break t)
      (quotation nil))
  (defun LaTeX-formatter (op &rest args)
    Ï1;; format document for processing by LaTeXÏ*
    Ï1;; This initial version is rather crude and needs refinement later.Ï*
    (case op
      (:tyo
       (setq line-break nil)
       (let ((char (first args)))
	 (block tyo
	   (case char
	     (#\space (when (>= column 70)
			(fresh-line)
			(setq column 0)))
	     ((#\$ #\& #\% #\# #\_ #\{ #\}) (write-char #\\))
	     ((#\~ #\^ #\\)
	      (write-string "\\verb|")
	      (write-char char)
	      (setq char #\|))
	     (#\" (cond (quotation 
			 (write-string "''")
			 (setq quotation nil))
			(t (write-string "``")
			   (setq quotation t)))
		  (setq char nil))
	     (#\page (format t "~&\\newpage")
		     (setq line-break t)
		     (setq char #\newline))
	     (#\tab (loop until (zerop (mod column 8))
			  do (progn (write-char #\~)
				    (incf column)))
		    (return-from tyo))
	     (#\newline
	      (when (zerop column) (setq char nil)))
	     (#\no-break-space (setq char #\~))
	     ((#\alpha #\beta #\gamma #\delta #\epsilon #\lambda #\pi)
	      (format t "$\\~A" (string-downcase (char-name char)))
	      (setq char #\$))
	     (#\mu (format t "$\\mu$") (setq char nil))
	     (#\down-horseshoe (format t "$\\cup$") (setq char nil))
	     (#\less-or-equal (format t "$\\leq$") (setq char nil))
	     (#\greater-or-equal (format t "$\\geq$") (setq char nil))
	     (#\not-equal (format t "$\\neq$") (setq char nil))
	     (#\left-horseshoe (format t "$\\subset$") (setq char nil))
	     (#\right-horseshoe (format t "$\\supset$") (setq char nil))
	     (#\left-arrow (format t "$\\leftarrow$") (setq char nil))
	     (#\right-arrow (format t "$\\rightarrow$") (setq char nil))
	     (#\up-arrow (format t "$\\uparrow$") (setq char nil))
	     (#\down-arrow (format t "$\\downarrow$") (setq char nil))
	     ((#\copyright)
	      (format t "\\~A" (string-downcase (char-name char)))
	      (setq char #\space))
	     (t nil)
	     )
	   (unless (null char)
	     (write-char char))
	   (setq column
		 (if (eql char #\newline)
		     0
		   (+ column 1)))
	   ) 					Ï1; end block Ï*tyo
	 (return-from LaTeX-formatter (char-int (first args)))
	 ))
      (:new-line (unless line-break
		   (format t " \\newline ")
		   (setq column 0)
		   (setq line-break t)))
      (:fresh-line (fresh-line) (setq column 0))
      (:new-paragraph (format t "~&~%")
		      (setq quotation nil)
		      (setq column 0) (setq line-break t))
      (:skip-line (format t "~&~%")
		  (when (first args)
		    (dotimes (i (- (first args) 1))
		      (format t " \\newline ")))
		  (setq column 0) (setq line-break t))
      (:new-page (format t "~&\\newpage~&"))
      ((:string-out :line-out)
       (let ((string (first args)))
	 (do ((i (or (second args) 0) (1+ i)))
	     ((>= i (or (third args) (length string))))
	   (LaTeX-formatter :tyo (char string i))))
       (when (eq op :line-out)
	 (LaTeX-formatter :tyo #\newline)))
      (:insert (format t "~&\\begin{verbatim}~%")
	       (let ((*formatter* #'text-formatter)
		     (*margin* 0)
		     (*line-length* (LaTeX-formatter :line-length)))
		 (apply (first args) (rest args)))
	       (format t "~&\\end{verbatim}~%")
	       (setq quotation nil)
	       (setq column 0)
	       (setq line-break t))
      (:new-section (format t "~&\\section{")
		    (setq column 9)
		    (LaTeX-formatter :string-out (first args))
		    (format t "}~%")
		    (setq quotation nil)
		    (setq column 0)
		    (setq line-break t))
      (:as-is-line (format t "~&\\begin{verbatim}~%")
		   (let ((*formatter* #'text-formatter))
		     (format-t-args args))
		   (format t "~&\\end{verbatim}~&")
		   (fresh-line) (setq quotation nil)
		   (setq column 0)
		   (setq line-break t))
      (:need-lines (format t "~&\\pagebreak[0]~&") 
		   (ignore (first args))
		   (setq column 0))
      (:separator-line
       (format t "~&\\begin{center}
------------------------------------------------------------------
\\end{center}~%")
       (setq column 0)
       (setq line-break t))
      (:begin-document
       (format t "~&\\documentstyle{article}~%\\begin{document}")
       (format t "~&\\title{Documentation for ~A ~A}~%\\date{~\\datime\\}~%"
	       (first args) (or (second args) ""))
       (format t "\\author{~A}~%\\maketitle~%" (string-capitalize (user-name)))
       (setq quotation nil)
       (setq column 0) (setq line-break t)
       )
      (:end-document (format t "~&\\end{document}~%"))
      (:comment  (format t "~&% ")
		 (let ((*formatter* #'text-formatter))
		   (format-t-args args))
		 (format t "~%"))
      (:line-length (return-from LaTeX-formatter 66.))	Ï1; number of characters between default marginsÏ*
      (t (return-from LaTeX-formatter (apply #'default-formatter op args)))
      )
    (values)))

(defun format-function (name)
  (if (null name)
      #'text-formatter
    (let ((x (assoc name '(("PDWS" PDWS-formatter)
			   ("TEXT" text-formatter)
			   ("SCRIBE" Scribe-formatter)
			   ("TEX" TeX-formatter)
                           ("LATEX" LaTeX-formatter))
		    :test #'string-equal)))
      (if x (symbol-function (second x))
	(error "~A is not a recognized format name." name)) )))

(defun write-attributes ()
  (send *formatter* :comment " -*- Mode: Text; Package: ~A; Base: ~D -*- "
	(package-name *package*) *print-base*))
