; -*- Mode:Lisp; Lowercase:True -*-

; Bolio init file for window system documentation

(declare (load '|liblsp;loop fasl|)
	 (include |ml:bolio;justdf >|)
	 (crunit dsk lmwind))

; Why aren't these declared??
(declare (special defun-pre-leading environment-type request-eol-p))

; Pessimal strings

(setsyntax '/" 'macro 'string-quote)

(defun string-quote ()
  (do ((l nil) (ch) (str))
      (nil)
    (setq ch (tyi))
    (cond ((= ch 42) (setq l (nreverse l) str (make-string (length l)))
		     (do ((i 0 (1+ i)) (l l (cdr l))) ((null l))
		       (as-1 (car l) str i))
		     (reclaim l t)
		     (return str))
	  ((= ch 57) (setq ch (tyi))))
    (push ch l)))

; Flavor documentation guy punches out forms like
;  (defprop flavor-name string flavor-documentation)

(defprop flavor-documentation flavor-documentation-request request)
(defun flavor-documentation-request ()
  (let ((flavor-name-string (get-word-string)) (flavor-name) (tem))
    (setq flavor-name (string-intern flavor-name-string))
    (flush-request-line)
    (cond ((setq tem (get flavor-name 'flavor-documentation))
	   (jin-push tem)				;I wonder if all this BS works?
	   (jin-push flavor-name-string)
	   (jin-push '|/
/
|)
	   (let ((request-eol-p nil))
	     (defflavor-request))
	   (end-defflavor-request))
	  (t (barf flavor-name '|has no flavor-documentation property|)))))

; Message and flavor and initoption indices

(setq flavor-index nil)
(defprop flavor-index |Flavor Index| index-title)
(defprop flavor-index 2 index-columns)

(setq message-index nil)
(defprop message-index |Message Index| index-title)
(defprop message-index 2 index-columns)

(setq initoption-index nil)
(defprop initoption-index |Window Creation Options| index-title)
(defprop initoption-index 2 index-columns)

;.defflavor, .defmethod, and .defmessage requests

(defprop defmessage defmessage-request request)
(defprop defmessage1 defmessage1-request request)
(defprop end_defmessage end-defmessage-request request)

(defun defmessage-request ()
  (check-env 'text 'defmessage)
  (or (need-space-mills 1000.) ;1 inch
      (output-leading-mills defun-pre-leading))
  (check-font-status 1)
  ((lambda (left-indent environment-type extra-left-indent-first-line-of-paragraph)
      (defmessage1-request)  ;Gobble the arguments, put out line, index, etc.
      (flush-request-line)
      (defun-horrible-tab-crock)
      (catch (main-loop) defmessage))
   (convert-mills 500.) ;1/2 inch indent
   'defmessage
   0))

(defun defmessage1-request ()
  (check-env 'defmessage 'defmessage1)
  (setq cur-hpos 0)
  ((lambda (message-name jin-cur-font)
      (or message-name (barf '|Message name missing in .defmessage or .defmessage1|))
      (add-to-index message-name 'message-index)
      (auto-setq message-name '|message|)
      (set-hpos left-margin)
      (put-string-flush-left message-name)
      (defun-line-proc))
   (get-word-string)
   8)
  (setq begin-new-paragraph nil))

(defun end-defmessage-request ()
  (check-env 'defmessage 'end_defmessage)
  (check-font-status 1)
  (*throw 'defmessage nil))

(defprop defmethod defmethod-request request)
(defprop defmethod1 defmethod1-request request)
(defprop end_defmethod end-defmethod-request request)

(defun defmethod-request ()
  (check-env 'text 'defmethod)
  (or (need-space-mills 1000.) ;1 inch
      (output-leading-mills defun-pre-leading))
  (check-font-status 1)
  ((lambda (left-indent environment-type extra-left-indent-first-line-of-paragraph)
      (defmethod1-request)  ;Gobble the arguments, put out line, index, etc.
      (flush-request-line)
      (defun-horrible-tab-crock)
      (catch (main-loop) defmethod))
   (convert-mills 500.) ;1/2 inch indent
   'defmethod
   0))

(declare (special defmethod-suppress-flavor-name))
(setq defmethod-suppress-flavor-name nil)

(defun defmethod1-request ()
  (check-env 'defmethod 'defmethod1)
  (setq cur-hpos 0)
  ((lambda (flavor-name message-name)
      (or flavor-name (barf '|Flavor name missing in .defmethod or .defmethod1|))
      (or message-name (barf '|Message name missing in .defmethod or .defmethod1|))
      (add-to-index (string-append message-name '|  (to | flavor-name '|)|) 'message-index)
      (just-setq (string-intern (string-append flavor-name '|-|
				       (substring message-name 1 (string-length message-name))
				       '|-method|))
		 (string-append '|page | (string-number page-number)))
      (set-hpos left-margin)
      (let ((jin-cur-font 8))
	(put-string-flush-left message-name))
      (defun-line-proc-no-newline)
      (cond ((not defmethod-suppress-flavor-name)
	     (let ((jin-cur-font 3))
	       (put-string-flush-left-maybe-terpri-first
		 (string-append '|1(to *| flavor-name '|1)*|)))))
      (defun-line-proc-newline))
   (get-word-string)
   (get-word-string)))

(defun end-defmethod-request ()
  (check-env 'defmethod 'end_defmethod)
  (check-font-status 1)
  (*throw 'defmethod nil))

(defprop defflavor defflavor-request request)
(defprop end_defflavor end-defflavor-request request)

(defun defflavor-request ()
  (check-env 'text 'defflavor)
  (or (need-space-mills 1000.)	;1 inch
      (output-leading-mills defun-pre-leading))
  (check-font-status 1)
  (setq cur-hpos 0)
  ((lambda (left-indent environment-type extra-left-indent-first-line-of-paragraph
	    flavor-name jin-cur-font)
      (or flavor-name (barf '|Flavor name missing in .defflavor|))
      (add-to-index flavor-name 'flavor-index)
      (auto-setq flavor-name '|flavor|)
      (set-hpos left-margin)
      (put-string-flush-left flavor-name)
      (jout-white-space (convert-mills 200.))
      (setq jin-cur-font 2)  ;italic
      (cond (request-eol-p (put-string-flush-left (string '|Flavor|)))
	    (t (put-string-flush-left (get-line-string))))
      (setq jin-cur-font 1)
      (line-advance)
      (setq begin-new-paragraph nil)
      (defun-horrible-tab-crock)
      (catch (main-loop) defflavor))
   (convert-mills 500.) ;1/2 inch indent
   'defflavor
   0
   (get-word-string)
   8))

(defun end-defflavor-request ()
  (check-env 'defflavor 'end_defflavor)
  (check-font-status 1)
  (*throw 'defflavor nil))

(defprop definitoption definitoption-request request)
(defprop definitoption1 definitoption1-request request)
(defprop end_definitoption end-definitoption-request request)

(defun definitoption-request ()
  (check-env 'text 'definitoption-request)
  (or (need-space-mills 1000.)	;1 inch
      (output-leading-mills defun-pre-leading))
  (check-font-status 1)
  ((lambda (left-indent environment-type extra-left-indent-first-line-of-paragraph)
      (definitoption1-request)
      (setq begin-new-paragraph nil)
      (defun-horrible-tab-crock)
      (catch (main-loop) definitoption))
   (convert-mills 500.) ;1/2 inch indent
   'definitoption
   0))

(defun definitoption1-request ()
  (let ((flavor-name (get-word-string))
	(option-name (get-word-string))
	(jin-cur-font 8))
    (check-env 'definitoption 'definitoption1-request)
    (setq cur-hpos 0)
    (or flavor-name (barf '|Flavor name missing in .definitoption|))
    (or option-name (barf '|Option name missing in .definitoption|))
    (add-to-index (string-append flavor-name '| | option-name) 'initoption-index)
    (just-setq (string-intern (string-append flavor-name '|-|
				 (substring option-name 1 (string-length option-name))
				 '|-init-option|))
	       (string-append '|page | (string-number page-number)))
    (set-hpos left-margin)
    (put-string-flush-left option-name)
    (defun-line-proc-no-newline)
    (let ((jin-cur-font 3))
      (put-string-flush-left-maybe-terpri-first
         (string-append '|1(Init Option for *| flavor-name '|1)*|)))
    (defun-line-proc-newline)))

(defun end-definitoption-request ()
  (check-env 'definitoption 'end_definitoption)
  (check-font-status 1)
  (*throw 'definitoption nil))

(defprop defresource defresource-request request)
(defprop defresource1 defresource1-request request)
(defprop end_defresource end-defresource-request request)

(defun defresource-request ()
  (check-env 'text 'defresource)
  (or (need-space-mills 1000.) ;1 inch
      (output-leading-mills defun-pre-leading))
  (check-font-status 1)
  ((lambda (left-indent environment-type extra-left-indent-first-line-of-paragraph)
      (defresource1-request)  ;Gobble the arguments, put out line, index, etc.
      (flush-request-line)
      (defun-horrible-tab-crock)
      (catch (main-loop) defresource))
   (convert-mills 500.) ;1/2 inch indent
   'defresource
   0))

(defun defresource1-request ()
  (check-env 'defresource 'defresource1)
  (setq cur-hpos 0)
  ((lambda (resource-name jin-cur-font)
      (or resource-name (barf '|Resource name missing in .defresource or .defresource1|))
      (add-to-index resource-name 'resource-index)
      (auto-setq resource-name '|resource|)
      (set-hpos left-margin)
      (put-string-flush-left resource-name)
      (defun-line-proc-no-newline)
      (put-string-flush-left-maybe-terpri-first '|1(Resource)*|)
      (defun-line-proc-newline))
   (get-word-string)
   8)
  (setq begin-new-paragraph nil))

(defun end-defresource-request ()
  (check-env 'defresource 'end_defresource)
  (check-font-status 1)
  (*throw 'defresource nil))

(defprop nopara nopara-request request)
(defun nopara-request ()
  (output-leading (* (or (get-numeric-arg) 1) xgp-line-height))
  (setq begin-new-paragraph nil))

;Code copied out of the middle of defun-line-proc
(declare (special DEFUN-ARG-SEPARATION-INTERNAL DEFUN-CONTINUATION-INDENT-INTERNAL))

(defun put-string-flush-left-maybe-terpri-first (string)
  (cond ((> (+ cur-hpos DEFUN-ARG-SEPARATION-INTERNAL (string-push-get-width string))
	    (- right-margin right-indent))
	 (line-advance)
	 (jout-white-space
	   (setq cur-hpos (+ left-margin left-indent
			     DEFUN-CONTINUATION-INDENT-INTERNAL))))
	(t (jout-white-space DEFUN-ARG-SEPARATION-INTERNAL)
	   (setq cur-hpos (+ cur-hpos DEFUN-ARG-SEPARATION-INTERNAL))))
  (output-nofill-line)				; output buffered string
  (jin-cleanup))

;Title-page kludgery

(DECLARE (SPECIAL SUPPRESS-HEADINGS))
(SETQ SUPPRESS-HEADINGS NIL)
(PUTPROP 'ORIGINAL-TOP-OF-PAGE (GET 'TOP-OF-PAGE 'SUBR) 'SUBR)
(PUTPROP 'ORIGINAL-BOTTOM-OF-PAGE (GET 'BOTTOM-OF-PAGE 'SUBR) 'SUBR)

(DEFUN TOP-OF-PAGE ()
  (OR SUPPRESS-HEADINGS (ORIGINAL-TOP-OF-PAGE)))

(DEFUN BOTTOM-OF-PAGE ()
  (OR SUPPRESS-HEADINGS (ORIGINAL-BOTTOM-OF-PAGE)))

(DEFPROP HEADINGS HEADINGS-REQUEST REQUEST)
(DEFUN HEADINGS-REQUEST ()
  (LET ((WD (GET-WORD-STRING)))
    (COND ((STRING-EQUAL WD 'ON) (SETQ SUPPRESS-HEADINGS NIL)
				 (RESET-PAGE-NUMBER 1))
	  ((STRING-EQUAL WD 'OFF) (SETQ SUPPRESS-HEADINGS T))
	  (T (BARF '|.HEADINGS arg of | WD '| should be ON or OFF|)))))

(sstatus uuolinks)

; Set up style and fonts

(default-manual-style nil '|New Window System|)
(standard-dover-fonts 10.)