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