542 lines
14 KiB

;;;; -*-Scheme-*-
;;;; $Revision: 1.22 $
;;;; Basic initializations
;;; --------------------------------------------------------------------------
;;; Define minimal reset, interrupt handler, and error handlers.
(if (call-with-current-continuation
(lambda (c)
(set! top-level-control-point c) #f))
(exit 1))
(define (interrupt-handler) (exit 1))
(define (error-handler . args)
(let ((port (error-port)))
(format port "~a: ~s: " (substitute "%progname%") (car args))
(apply format port (cdr args))
(newline port)
(exit 1)))
;;; --------------------------------------------------------------------------
;;; Procedures to print an error message and quit and to print warnings.
(define (quit msg . args)
(let ((port (error-port)))
(display (substitute "%progname%:%filepos% ") port)
(apply format port msg args)
(newline port))
(exit 1))
(define (warn msg . args)
(let ((port (error-port)))
(display (substitute "%progname%:%filepos% warning: ") port)
(apply format port msg args)
(newline port)
"")) ; return "" to assist use in event functions
(define (surprise msg)
(warn (concat msg " may not work as expected")))
;;; --------------------------------------------------------------------------
;;; Miscellaneous utilities.
(define-macro (++ var) `(set! ,var (1+ ,var)))
(define-macro (-- var) `(set! ,var (1- ,var)))
(define (identity x) x)
(define (copy-apply reader . procedures)
(define (apply-all val procs)
(if (null? procs)
((car procs) (apply-all val (cdr procs)))))
(let loop ((x (reader)))
(cond ((eof-object? x) "")
(apply-all x procedures)
(loop (reader))))))
(define-macro (list-push! list elem)
`(set! ,list (cons ,elem ,list)))
(define-macro (list-pop! list)
`(set! ,list (cdr ,list)))
(define-macro (list-clear! list)
`(set! ,list '()))
(define (skip-lines stop)
(let ((x (read-line-expand)))
(cond ((eof-object? x)
(warn "end-of-stream while skipping input"))
((not (string=? x stop))
(skip-lines stop)))))
;;; Assist setting of options in initialization file:
(define-macro (eval-if-mode mode . body)
(if (and (pair? mode)
(= (length mode) 2)
(symbol? (car mode))
(symbol? (cadr mode)))
(let ((tmac (car mode)) (format (cadr mode)))
((and (or (eq? ',tmac '*)
(eq? ',tmac (string->symbol (substitute "m%macros%"))))
(or (eq? ',format '*)
(eq? ',format (string->symbol (substitute "%format%")))))
(error 'eval-if-mode "badly formed mode argument: `~a'" mode)))
;;; Macro to define a function and a predicate to manage requests that
;;; come in pairs, such as .fi/.nf.
(define-macro (define-pair func inside enter leave)
(define ,inside #f)
(define (,func on)
(if on
(if ,inside "" ,enter)
(if ,inside ,leave ""))
(set! ,inside on)))))
;;; Like define-pair, but for nested pairs.
(define-macro (define-nested-pair func level enter leave)
(define ,level 0)
(define (,func op)
(case op
(0 (begin1 (repeat-string ,level ,leave) (set! ,level 0)))
(+ (++ ,level) ,enter)
(- (if (zero? ,level)
(-- ,level) ,leave))))))
;;; --------------------------------------------------------------------------
;;; Options.
(define option-types (make-table 10))
(define option-table (make-table 100))
(define (define-option-type name check1 msg1 convert check2 msg2)
(table-store! option-types name (list check1 msg1 convert check2 msg2)))
(define (define-option name type initial)
(if (not (table-lookup option-types type))
(quit "bad type `~a' for define-option" type))
(table-store! option-table name (cons initial type)))
(define (option-setter as-event?)
(lambda (name value)
(let* ((opt (table-lookup option-table name))
(t (if opt (table-lookup option-types (cdr opt)) #f))
(err (lambda (msg) (quit "option `~a' requires ~a as value"
name msg))))
(if opt
(let ((val value))
(if as-event?
(if (not ((car t) val)) (err (cadr t)))
(set! val ((caddr t) (car opt) val))))
(if (not ((cadddr t) val)) (err (car (cddddr t))))
(set-car! opt val))
(quit "undefined option: `~a'" name)))))
(defevent 'option 0 (option-setter #t))
(define set-option! (option-setter #f))
(define (option name)
(let ((opt (table-lookup option-table name)))
(if opt (car opt) (quit "undefined option: `~a'" name))))
(define-option-type 'integer
string? ""
(lambda (old new) (string->number new))
integer? "an integer")
(define-option-type 'boolean
(lambda (x) (member x '("0" "1"))) "0 or 1"
(lambda (old new) (string=? new "1"))
boolean? "a boolean")
(define-option-type 'character
(lambda (x) (= (string-length x) 1)) "a character"
(lambda (old new) (string-ref new 0))
char? "a character")
(define-option-type 'string
string? ""
(lambda (old new) new)
string? "a string")
(define-option-type 'dynstring
string? ""
string? "a string")
;;; --------------------------------------------------------------------------
;;; Utilities for working with streams.
(define (with-i/o name proc opener setter!)
(let* ((new (opener name)) (old (setter! new)) (result (proc)))
(setter! old)
(close-stream new)
(define-macro (with-output-to-stream name . body)
`(with-i/o ,name (lambda () ,@body) open-output-stream set-output-stream!))
(define-macro (with-output-appended-to-stream name . body)
`(with-i/o ,name (lambda () ,@body) append-output-stream set-output-stream!))
(define-macro (with-input-from-stream name . body)
`(with-i/o ,name (lambda () ,@body) open-input-stream set-input-stream!))
;;; --------------------------------------------------------------------------
;;; Basic troff requests that are not output format specific.
(defrequest 'tm
(lambda (tm arg)
(display arg (error-port))
(newline (error-port))))
(define-option 'include-files 'boolean #t)
(defrequest 'so
(lambda (so fn)
((eqv? fn "")
(warn "missing filename for .so"))
((option 'include-files)
(with-input-from-stream fn
(copy-apply read-line-expand parse-line)))
(else ""))))
(defrequest 'ec
(lambda (ec c)
((eqv? c "")
(set-escape! #\\))
((= (string-length c) 1)
(set-escape! (string-ref c 0)))
(warn "non-character argument for .ec")
(set-escape! #\\)))))
(defrequest 'rm
(lambda (rm . names)
(lambda (x)
(defrequest x #f)
(defstring x #f))
names) ""))
;;; --------------------------------------------------------------------------
;;; Inline Scheme code execution; transparent output.
(define \##-env (the-environment))
(define (\##-eval expr) (eval expr \##-env))
(defrequest 'ig
(lambda (ig delim)
(define (copy-exec stop what)
(let loop ((s (read-line)))
(cond ((eof-object? s)
(warn "end-of-stream during ~a" what))
((not (string=? s stop))
(emit s)
(loop (read-line))))))
((string=? delim "##")
(with-output-to-stream 'hash-hash
(copy-exec ".##\n" "inline Scheme execution"))
(let ((p (open-input-string (stream->string 'hash-hash))))
(copy-apply (lambda () (read p)) \##-eval)))
((string=? delim ">>")
(copy-exec ".>>\n" "transparent output"))
(skip-lines (concat #\. (if (eqv? delim "") #\. delim) #\newline))))
(defrequest '\##
(lambda (\## sexpr)
(let ((p (open-input-string sexpr)))
(copy-apply (lambda () (read p)) \##-eval))))
(defrequest '>>
(lambda (>> code) (emit code #\newline)))
;;; --------------------------------------------------------------------------
;;; User-defined macros.
(define arg-stack '())
(defescape '$
(lambda ($ n)
(let ((i (string->number n)))
((not i)
((string=? n "*")
(if (null? arg-stack) "" (apply spread (cdar arg-stack))))
((string=? n "@")
(let loop ((a (if (null? arg-stack) '() (cdar arg-stack))))
(cond ((null? a)
((null? (cdr a))
(concat #\" (car a) #\"))
(concat #\" (car a) #\" #\space (loop (cdr a)))))))
(warn "invalid $ argument `~a'" n))))
((or (null? arg-stack) (>= i (length (car arg-stack))))
(else (list-ref (car arg-stack) i))))))
(defnumreg '.$
(lambda _
(number->string (if (null? arg-stack) 0 (1- (length (car arg-stack)))))))
(define (macro-buffer-name s) (concat "[." s "]"))
(define (expand-macro . args)
(list-push! arg-stack args)
(with-input-from-stream (macro-buffer-name (car args))
(copy-apply read-line-expand parse-line parse-copy-mode))
(list-pop! arg-stack) "")
(define (copy-macro-body)
(let* ((s (read-line-expand))
(t (if (eof-object? s) #f (parse-copy-mode s))))
(cond ((not t)
(warn "end-of-stream during macro definition"))
((not (string=? t "..\n"))
(emit t)
(defrequest 'de
(lambda (de name)
(cond ((eqv? name "")
(warn "missing name for .de"))
(with-output-to-stream (macro-buffer-name name)
(defmacro name expand-macro) ""))))
(defrequest 'am
(lambda (am name)
(cond ((eqv? name "")
(warn "missing name for .am"))
(with-output-appended-to-stream (macro-buffer-name name)
(defmacro name expand-macro) ""))))
;;; --------------------------------------------------------------------------
;;; if, if-else, else.
(defescape #\{ "")
(defescape #\} "")
(defrequest "\\}" "") ; do not complain about .\}
(define-option 'if-true 'dynstring "to")
(define-option 'if-false 'dynstring "ne")
(define if-stack '())
(define (if-request request condition rest)
(let* ((doit? #f)
(c (string-prune-left condition "!" condition))
(len (string-length c))
(neg? (not (eq? c condition))))
((and (= len 1) (char-alphabetic? (string-ref c 0)))
((substring? c (option 'if-true))
(set! doit? #t))
((substring? c (option 'if-false)))
(else (warn "unknown if-condition `~a'" c))))
((and (> len 0) (char-expression-delimiter? (string-ref c 0)))
(let ((x (parse-expression c #f #\u)))
(if x (set! doit? (not (zero? x))))))
(let ((pair (parse-pair c)))
(if pair
(set! doit? (string=? (car pair) (cdr pair)))
(warn "if-condition `~a' not understood" c)))))
((eq? neg? doit?)
(unread-line (concat rest #\newline))
(unread-line (hack-if-argument rest))))
(if (string=? request "ie")
(list-push! if-stack (not (eq? neg? doit?))))
;; Some people like to write .if requests such as
;; .if t \{\
;; .foo
;; This causes the string "\{.foo" to be passed to .if, as the first line
;; is a continuation line. So let's strip the initial \{. What a hack.
(define (hack-if-argument s)
(string-prune-left s "\\{" s))
(defrequest 'if if-request)
(defrequest 'ie if-request)
(defrequest 'el
(lambda (_ rest)
((null? if-stack)
(warn ".el without matching .ie request"))
((car if-stack)
(unread-line (concat rest #\newline))
(list-pop! if-stack))
(unread-line (hack-if-argument rest))
(list-pop! if-stack)))
;;; --------------------------------------------------------------------------
;;; Number registers.
(define numreg-table (make-table 65536))
(defrequest 'nr
(lambda (nr name val incr)
((eqv? name "")
(warn "missing name for .nr"))
((eqv? val "")
(warn "missing value for .nr"))
(let* ((old (table-lookup numreg-table name))
(v (parse val))
(n (parse-expression v #f #\u))
(add? (string-prune-left v "+" #f))
(i (if (eqv? incr "")
(parse-expression (parse incr) #f #\u))))
((not n) "")
(set-car! old (if (or add? (negative? n)) (+ (car old) n) n))
(if i
(set-cdr! old i)))
(table-store! numreg-table name (cons n (if i i 0))))))))
(defescape 'n
(lambda (_ name . sign)
(let ((val (table-lookup numreg-table name)))
(if (not (null? sign))
(case (car sign)
(#\+ (set-car! val (+ (car val) (cdr val))))
(#\- (set-car! val (- (car val) (cdr val))))))
(number->string (car val)))
(else (warn "undefined number register: `~a'" name) "0")))))
(defrequest 'rr
(lambda (rr . names)
(lambda (x)
(defnumreg x #f)
(table-remove! numreg-table x))
names) ""))
;;; Predefined number registers
(defnumreg 'dw
(lambda _
(number->string (1+ (string->number (substitute "%weekdaynum%"))))))
(defnumreg 'dy (lambda _ (substitute "%day%")))
(defnumreg 'mo (lambda _ (substitute "%month%")))
(defnumreg 'yr (lambda _ (substring (substitute "%year%") 2 4)))
(defnumreg '.C (lambda _ (if (troff-compatible?) #\1 #\0)))
(defnumreg '% #\0)
(defnumreg '.z "")
(defnumreg '.U #\1)
;;; --------------------------------------------------------------------------
;;; Strings. Note that user-defined strings are re-scanned (strings
;;; defined via `defstring' aren't, because they may contain anything).
(defrequest 'ds
(lambda (ds name val)
(if (eqv? name "")
(warn "missing name for .ds")
(let ((v (string-prune-left val "\"" val)))
(defstring name (lambda _ (parse-expand v)))))
(defrequest 'as
(lambda (as name val)
(if (eqv? name "")
(warn "missing name for .as")
(let* ((f (stringdef name))
(s (if f (if (string? f) f (f)) ""))
(new (concat s (string-prune-left val "\"" val))))
(defstring name (lambda _ (parse-expand new)))))
(defescape '*
(lambda (_ name)
(warn "undefined string: `~a'" name)))
;;; --------------------------------------------------------------------------
;;; Now we are done with the definitions.
;;; Load the output-format-specific Scheme code and the macro-package-
;;; specific Scheme code.
(load (substitute "%directory%/scm/%format%/common.scm"))
(load (substitute "%directory%/scm/%format%/m%macros%.scm"))
(set! garbage-collect-notify? #f)
(append! load-path (list (substitute "%directory%/scm/misc")))