1;;;; -*-Scheme-*-
2;;;;
3;;;; $Revision: 1.22 $
4;;;;
5;;;; Basic initializations
6
7
8;;; --------------------------------------------------------------------------
9;;; Define minimal reset, interrupt handler, and error handlers.
10
11(if (call-with-current-continuation
12      (lambda (c)
13	(set! top-level-control-point c) #f))
14    (exit 1))
15
16(define (interrupt-handler) (exit 1))
17
18(define (error-handler . args)
19  (let ((port (error-port)))
20    (format port "~a: ~s: " (substitute "%progname%") (car args))
21    (apply format port (cdr args))
22    (newline port)
23    (exit 1)))
24
25
26
27;;; --------------------------------------------------------------------------
28;;; Procedures to print an error message and quit and to print warnings.
29
30(define (quit msg . args)
31  (let ((port (error-port)))
32    (display (substitute "%progname%:%filepos% ") port)
33    (apply format port msg args)
34    (newline port))
35  (exit 1))
36
37(define (warn msg . args)
38  (let ((port (error-port)))
39    (display (substitute "%progname%:%filepos% warning: ") port)
40    (apply format port msg args)
41    (newline port)
42    ""))    ; return "" to assist use in event functions
43
44(define (surprise msg)
45  (warn (concat msg " may not work as expected")))
46
47
48
49;;; --------------------------------------------------------------------------
50;;; Miscellaneous utilities.
51
52(define-macro (++ var) `(set! ,var (1+ ,var)))
53(define-macro (-- var) `(set! ,var (1- ,var)))
54
55(define (identity x) x)
56
57
58(define (copy-apply reader . procedures)
59  (define (apply-all val procs)
60    (if (null? procs)
61	val
62	((car procs) (apply-all val (cdr procs)))))
63  (let loop ((x (reader)))
64       (cond ((eof-object? x) "")
65	     (else
66	       (apply-all x procedures)
67	       (loop (reader))))))
68
69
70(define-macro (list-push! list elem)
71  `(set! ,list (cons ,elem ,list)))
72
73(define-macro (list-pop! list)
74  `(set! ,list (cdr ,list)))
75
76(define-macro (list-clear! list)
77  `(set! ,list '()))
78
79
80(define (skip-lines stop)
81  (let ((x (read-line-expand)))
82    (cond ((eof-object? x)
83	    (warn "end-of-stream while skipping input"))
84	  ((not (string=? x stop))
85	    (skip-lines stop)))))
86
87
88;;; Assist setting of options in initialization file:
89
90(define-macro (eval-if-mode mode . body)
91  (if (and (pair? mode)
92	   (= (length mode) 2)
93	   (symbol? (car mode))
94	   (symbol? (cadr mode)))
95      (let ((tmac (car mode)) (format (cadr mode)))
96        `(cond
97	   ((and (or (eq? ',tmac '*)
98		     (eq? ',tmac (string->symbol (substitute "m%macros%"))))
99	         (or (eq? ',format '*)
100		     (eq? ',format (string->symbol (substitute "%format%")))))
101	     ,@body)))
102      (error 'eval-if-mode "badly formed mode argument: `~a'" mode)))
103
104
105;;; Macro to define a function and a predicate to manage requests that
106;;; come in pairs, such as .fi/.nf.
107
108(define-macro (define-pair func inside enter leave)
109  `(begin
110     (define ,inside #f)
111     (define (,func on)
112       (begin1
113	 (if on
114	     (if ,inside "" ,enter)
115	     (if ,inside ,leave ""))
116	 (set! ,inside on)))))
117
118
119;;; Like define-pair, but for nested pairs.
120
121(define-macro (define-nested-pair func level enter leave)
122  `(begin
123     (define ,level 0)
124     (define (,func op)
125       (case op
126       (0 (begin1 (repeat-string ,level ,leave) (set! ,level 0)))
127       (+ (++ ,level) ,enter)
128       (- (if (zero? ,level)
129	      ""
130              (-- ,level) ,leave))))))
131
132
133
134;;; --------------------------------------------------------------------------
135;;; Options.
136
137(define option-types (make-table 10))
138(define option-table (make-table 100))
139
140(define (define-option-type name check1 msg1 convert check2 msg2)
141  (table-store! option-types name (list check1 msg1 convert check2 msg2)))
142
143(define (define-option name type initial)
144  (if (not (table-lookup option-types type))
145      (quit "bad type `~a' for define-option" type))
146  (table-store! option-table name (cons initial type)))
147
148(define (option-setter as-event?)
149  (lambda (name value)
150    (let* ((opt (table-lookup option-table name))
151	   (t (if opt (table-lookup option-types (cdr opt)) #f))
152	   (err (lambda (msg) (quit "option `~a' requires ~a as value"
153			            name msg))))
154      (if opt
155          (let ((val value))
156	    (if as-event?
157	        (begin
158                  (if (not ((car t) val)) (err (cadr t)))
159	          (set! val ((caddr t) (car opt) val))))
160            (if (not ((cadddr t) val)) (err (car (cddddr t))))
161            (set-car! opt val))
162	  (quit "undefined option: `~a'" name)))))
163
164(defevent 'option 0 (option-setter #t))
165(define set-option! (option-setter #f))
166
167(define (option name)
168  (let ((opt (table-lookup option-table name)))
169    (if opt (car opt) (quit "undefined option: `~a'" name))))
170
171(define-option-type 'integer
172   string? ""
173   (lambda (old new) (string->number new))
174   integer? "an integer")
175
176(define-option-type 'boolean
177   (lambda (x) (member x '("0" "1"))) "0 or 1"
178   (lambda (old new) (string=? new "1"))
179   boolean? "a boolean")
180
181(define-option-type 'character
182   (lambda (x) (= (string-length x) 1)) "a character"
183   (lambda (old new) (string-ref new 0))
184   char? "a character")
185
186(define-option-type 'string
187   string? ""
188   (lambda (old new) new)
189   string? "a string")
190
191(define-option-type 'dynstring
192  string? ""
193  string-compose
194  string? "a string")
195
196
197
198;;; --------------------------------------------------------------------------
199;;; Utilities for working with streams.
200
201(define (with-i/o name proc opener setter!)
202  (let* ((new (opener name)) (old (setter! new)) (result (proc)))
203    (setter! old)
204    (close-stream new)
205    result))
206
207(define-macro (with-output-to-stream name . body)
208  `(with-i/o ,name (lambda () ,@body) open-output-stream set-output-stream!))
209
210(define-macro (with-output-appended-to-stream name . body)
211  `(with-i/o ,name (lambda () ,@body) append-output-stream set-output-stream!))
212
213(define-macro (with-input-from-stream name . body)
214  `(with-i/o ,name (lambda () ,@body) open-input-stream set-input-stream!))
215
216
217
218;;; --------------------------------------------------------------------------
219;;; Basic troff requests that are not output format specific.
220
221(defrequest 'tm
222  (lambda (tm arg)
223    (display arg (error-port))
224    (newline (error-port))))
225
226(define-option 'include-files 'boolean #t)
227
228(defrequest 'so
229  (lambda (so fn)
230    (cond
231      ((eqv? fn "")
232	(warn "missing filename for .so"))
233      ((option 'include-files)
234        (with-input-from-stream fn
235          (copy-apply read-line-expand parse-line)))
236      (else ""))))
237
238(defrequest 'ec
239  (lambda (ec c)
240    (cond
241      ((eqv? c "")
242	(set-escape! #\\))
243      ((= (string-length c) 1)
244	(set-escape! (string-ref c 0)))
245      (else
246	(warn "non-character argument for .ec")
247	(set-escape! #\\)))))
248
249(defrequest 'rm
250  (lambda (rm . names)
251    (for-each
252      (lambda (x)
253	(defrequest x #f)
254	(defstring x #f))
255      names) ""))
256
257
258
259;;; --------------------------------------------------------------------------
260;;; Inline Scheme code execution; transparent output.
261
262(define \##-env (the-environment))
263(define (\##-eval expr) (eval expr \##-env))
264
265(defrequest 'ig
266  (lambda (ig delim)
267    (define (copy-exec stop what)
268      (let loop ((s (read-line)))
269	   (cond ((eof-object? s)
270		   (warn "end-of-stream during ~a" what))
271		 ((not (string=? s stop))
272		   (emit s)
273		   (loop (read-line))))))
274    (cond
275      ((string=? delim "##")
276	(with-output-to-stream '[##]
277	  (copy-exec ".##\n" "inline Scheme execution"))
278	(let ((p (open-input-string (stream->string '[##]))))
279	  (copy-apply (lambda () (read p)) \##-eval)))
280      ((string=? delim ">>")
281	(copy-exec ".>>\n" "transparent output"))
282      (else
283        (skip-lines (concat #\. (if (eqv? delim "") #\. delim) #\newline))))
284    ""))
285
286(defrequest '\##
287  (lambda (\## sexpr)
288    (let ((p (open-input-string sexpr)))
289      (copy-apply (lambda () (read p)) \##-eval))))
290
291(defrequest '>>
292  (lambda (>> code) (emit code #\newline)))
293
294
295
296;;; --------------------------------------------------------------------------
297;;; User-defined macros.
298
299(define arg-stack '())
300
301(defescape '$
302  (lambda ($ n)
303    (let ((i (string->number n)))
304      (cond
305	((not i)
306	  (cond
307	    ((string=? n "*")
308	      (if (null? arg-stack) "" (apply spread (cdar arg-stack))))
309	    ((string=? n "@")
310	      (let loop ((a (if (null? arg-stack) '() (cdar arg-stack))))
311		   (cond ((null? a)
312		           "")
313			 ((null? (cdr a))
314			   (concat #\" (car a) #\"))
315			 (else
316		           (concat #\" (car a) #\" #\space (loop (cdr a)))))))
317	    (else
318	     (warn "invalid $ argument `~a'" n))))
319	((or (null? arg-stack) (>= i (length (car arg-stack))))
320	  "")
321	(else (list-ref (car arg-stack) i))))))
322
323(defnumreg '.$
324  (lambda _
325    (number->string (if (null? arg-stack) 0 (1- (length (car arg-stack)))))))
326
327(define (macro-buffer-name s) (concat "[." s "]"))
328
329(define (expand-macro . args)
330  (list-push! arg-stack args)
331  (with-input-from-stream (macro-buffer-name (car args))
332    (copy-apply read-line-expand parse-line parse-copy-mode))
333  (list-pop! arg-stack) "")
334
335(define (copy-macro-body eom)
336  (let* ((s (read-line-expand))
337	 (t (if (eof-object? s) #f (parse-copy-mode s))))
338    (cond ((not t)
339	    (warn "end-of-stream during macro definition"))
340	  ((not (string=? t eom))
341	    (emit t)
342	    (copy-macro-body eom)))))
343
344(defrequest 'de
345  (lambda (de name . end)
346    (let ((eom (if (null? end) "..\n" (concat "." (car end) "\n"))))
347    (cond ((eqv? name "")
348	    (warn "missing name for .de"))
349	  (else
350            (with-output-to-stream (macro-buffer-name name)
351              (copy-macro-body eom))
352            (defmacro name expand-macro) "")))))
353
354(defrequest 'am
355  (lambda (am name . end)
356    (let ((eom (if (null? end) "..\n" (concat "." (car end) "\n"))))
357    (cond ((eqv? name "")
358	    (warn "missing name for .am"))
359	  (else
360            (with-output-appended-to-stream (macro-buffer-name name)
361              (copy-macro-body eom))
362            (defmacro name expand-macro) "")))))
363
364
365
366;;; --------------------------------------------------------------------------
367;;; if, if-else, else.
368
369;; Version of parse-pair that will pick off pair expression, evaluate and return
370;; remainder following.
371(define (trim-leading-blanks stuff)
372   (let ((l (string-length stuff)))
373     (let loop ((i 0))
374       (cond
375	 ((>= i l) " ")
376	 ((not (char=? #\space (string-ref stuff i)))
377	   (substring stuff i l))
378	 (else (loop (+ i 1)))))))
379
380(define (parse-pair-rest stuff)
381  (let ((c (string-ref stuff 0))
382	(l (string-length stuff))
383	(result '#f))
384    (let loop ((i 2))
385      (cond
386	((>= i l) (cons '#f stuff))
387	((not (char=? c (string-ref stuff i)))
388	   (loop (+ i 1)))
389	(else
390	  (set! result (parse-pair (substring stuff 0 (+ i 1))))
391	  (if result
392	    (cons result (trim-leading-blanks (substring stuff (+ i 1) l)))
393	    (loop (+ i 1))))))))
394
395
396(defescape #\{ "")
397(defescape #\} "")
398(defrequest "\\}" "")    ; do not complain about .\}
399
400(define-option 'if-true  'dynstring "to")
401(define-option 'if-false 'dynstring "ne")
402
403(define if-stack '())
404
405(define (if-request request condition)
406  (let* ((doit? #f)
407	 (c (string-prune-left condition "!" condition))
408	 (len (string-length c))
409	 (neg? (not (eq? c condition)))
410	 (rest ""))
411    (cond
412      ((< len 1)
413	(warn "missing .~a condition" request))
414      ((and (char=? #\space (string-ref c 1)) (char-alphabetic? (string-ref c 0)))
415	(cond
416	  ((substring? (string (string-ref c 0)) (option 'if-true))
417	     (set! doit? #t))
418	  ((substring? (string (string-ref c 0)) (option 'if-false)))
419	  (else (warn "unknown .~a condition `~a'" request c)))
420	  (set! rest (trim-leading-blanks (substring c 2 (string-length c)))))
421      ((and (> len 0) (char-expression-delimiter? (string-ref c 0)))
422	(let* ((rem (parse-expression-rest c #f #\u))
423	      (x (car rem)))
424	  (if x (set! doit? (not (zero? x)))
425		(warn "invalid .~a expression ~a" request c))
426	  (set! rest (trim-leading-blanks (cdr rem)))))
427      (else
428        (let* ((rem (parse-pair-rest c))
429	       (pair (car rem)))
430	  (if pair
431	    (set! doit? (string=? (caar rem) (cdar rem)))
432	    (warn ".~a condition `~a' not understood" request c))
433	  (set! rest (cdr rem)))))
434;;  If compound .ie, watch out for another .ie in false clause -- need to do
435;;  extra skip-group, e.g.
436;;  .ie `yes`yes` .ok
437;;  .el .ie `no`yes` .no
438;;  .el .no
439    (cond
440      ((eq? neg? doit?) (begin
441	(unread-line (concat rest #\newline)) (skip-group)
442	(if (string=? ".ie" (substring rest 0 (min 3 (string-length rest))))
443	  (skip-group))))
444      (else
445        (unread-line (hack-if-argument rest))))
446    (if (string=? request "ie")
447	(list-push! if-stack (not (eq? neg? doit?))))
448    ""))
449
450;; Some people like to write .if requests such as
451;;    .if t \{\
452;;    .foo
453;; This causes the string "\{.foo" to be passed to .if, as the first line
454;; is a continuation line.  So let's strip the initial \{.  What a hack.
455
456(define (hack-if-argument s)
457  (string-prune-left s "\\{" s))
458
459(defrequest 'if if-request)
460(defrequest 'ie if-request)
461
462(defrequest 'el
463  (lambda (_ rest)
464    (cond
465      ((null? if-stack)
466	 (warn ".el without matching .ie request"))
467      ((car if-stack)
468;;       If compound .ie, watch out for another .ie in false clause -- need to
469;;       do extra skip-group, e.g.
470;;       .ie `yes`yes` .ok
471;;       .el .ie `no`yes` .no
472;;       .el .no
473	 (unread-line (concat rest #\newline)) (skip-group)
474	 (if (string=? ".ie" (substring rest 0 (min 3 (string-length rest))))
475	   (skip-group))
476	 (list-pop! if-stack))
477      (else
478         (unread-line (hack-if-argument rest))
479	 (list-pop! if-stack)))
480    ""))
481
482
483
484;;; --------------------------------------------------------------------------
485;;; Number registers.
486
487(define numreg-table (make-table 65536))
488
489(defrequest 'nr
490  (lambda (nr name val incr)
491    (cond
492      ((eqv? name "")
493	(warn "missing name for .nr"))
494      ((eqv? val "")
495	(warn "missing value for .nr"))
496      (else
497	(let* ((old (table-lookup numreg-table name))
498	       (v (parse val))
499	       (n (parse-expression v #f #\u))
500	       (add? (string-prune-left v "+" #f))
501	       (i (if (eqv? incr "")
502		      #f
503		      (parse-expression (parse incr) #f #\u))))
504	  (cond
505	    ((not n) "")
506	    (old
507	      (set-car! old (if (or add? (negative? n)) (+ (car old) n) n))
508	      (if i
509	          (set-cdr! old i)))
510	    (else
511	      (table-store! numreg-table name (cons n (if i i 0))))))))
512    ""))
513
514(defescape 'n
515  (lambda (_ name . sign)
516    (let ((val (table-lookup numreg-table name)))
517      (cond
518	(val
519	  (if (not (null? sign))
520	      (case (car sign)
521	      (#\+  (set-car! val (+ (car val) (cdr val))))
522	      (#\-  (set-car! val (- (car val) (cdr val))))))
523	  (number->string (car val)))
524	(else (warn "undefined number register: `~a'" name) "0")))))
525
526(defrequest 'rr
527  (lambda (rr . names)
528    (for-each
529      (lambda (x)
530	(defnumreg x #f)
531	(table-remove! numreg-table x))
532      names) ""))
533
534
535;;; Predefined number registers
536
537(defnumreg 'dw
538  (lambda _
539    (number->string (1+ (string->number (substitute "%weekdaynum%"))))))
540
541(defnumreg 'dy (lambda _ (substitute "%day%")))
542(defnumreg 'mo (lambda _ (substitute "%month%")))
543(defnumreg 'yr (lambda _ (substring (substitute "%year%") 2 4)))
544(defnumreg '.C (lambda _ (if (troff-compatible?) #\1 #\0)))
545(defnumreg '% #\0)
546(defnumreg '.z "")
547(defnumreg '.U #\1)
548
549
550
551;;; --------------------------------------------------------------------------
552;;; Strings.  Note that user-defined strings are re-scanned (strings
553;;; defined via `defstring' aren't, because they may contain anything).
554
555(defrequest 'ds
556  (lambda (ds name val)
557    (if (eqv? name "")
558	(warn "missing name for .ds")
559	(let ((v (string-prune-left val "\"" val)))
560	  (defstring name (lambda _ (parse-expand v)))))
561    ""))
562
563(defrequest 'as
564  (lambda (as name val)
565    (if (eqv? name "")
566	(warn "missing name for .as")
567        (let* ((f (stringdef name))
568	       (s (if f (if (string? f) f (f)) ""))
569	       (new (concat s (string-prune-left val "\"" val))))
570	  (defstring name (lambda _ (parse-expand new)))))
571    ""))
572
573(defescape '*
574  (lambda (_ name)
575    (warn "undefined string: `~a'" name)))
576
577
578
579;;; --------------------------------------------------------------------------
580;;; Now we are done with the definitions.
581;;;
582;;; Load the output-format-specific Scheme code and the macro-package-
583;;; specific Scheme code.
584
585(load (substitute "%directory%/scm/%format%/common.scm"))
586
587(load (substitute "%directory%/scm/%format%/m%macros%.scm"))
588
589(set! garbage-collect-notify? #f)
590
591(append! load-path (list (substitute "%directory%/scm/misc")))
592