| 1 | ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; **********************************************************************
|
|---|
| 4 | ;;; This code was written as part of the CMU Common Lisp project at
|
|---|
| 5 | ;;; Carnegie Mellon University, and has been placed in the public domain.
|
|---|
| 6 | ;;;
|
|---|
| 7 | #+CMU (ext:file-comment
|
|---|
| 8 | "$Header$")
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; **********************************************************************
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; Written by Bill Chiles
|
|---|
| 13 | ;;;
|
|---|
| 14 | ;;; Terminal Capability
|
|---|
| 15 | ;;;
|
|---|
| 16 | ;;; This stuff parses a Termcap file and returns a data structure suitable
|
|---|
| 17 | ;;; for initializing a redisplay methods device.
|
|---|
| 18 | ;;;
|
|---|
| 19 |
|
|---|
| 20 | (in-package :hemlock-internals)
|
|---|
| 21 |
|
|---|
| 22 |
|
|---|
| 23 | |
|---|
| 24 |
|
|---|
| 25 | ;;;; Interface for device creating code.
|
|---|
| 26 |
|
|---|
| 27 | (defun get-termcap (name)
|
|---|
| 28 | "Look in TERMCAP environment variable for terminal capabilities or a
|
|---|
| 29 | file to use. If it is a file, look for name in it. If it is a description
|
|---|
| 30 | of the capabilities, use it, and don't look for name anywhere. If TERMCAP
|
|---|
| 31 | is undefined, look for name in termcap-file. An error is signaled if it
|
|---|
| 32 | cannot find the terminal capabilities."
|
|---|
| 33 | (let ((termcap-env-var (get-termcap-env-var)))
|
|---|
| 34 | (if termcap-env-var
|
|---|
| 35 | (if (char= (schar termcap-env-var 0) #\/) ; hack for filenamep
|
|---|
| 36 | (with-open-file (s termcap-env-var)
|
|---|
| 37 | (if (find-termcap-entry name s)
|
|---|
| 38 | (parse-fields s)
|
|---|
| 39 | (error "Unknown Terminal ~S in file ~S." name termcap-env-var)))
|
|---|
| 40 | (with-input-from-string (s termcap-env-var)
|
|---|
| 41 | (skip-termcap-names s)
|
|---|
| 42 | (parse-fields s)))
|
|---|
| 43 | (with-open-file (s termcap-file)
|
|---|
| 44 | (if (find-termcap-entry name s)
|
|---|
| 45 | (parse-fields s)
|
|---|
| 46 | (error "Unknown Terminal ~S in file ~S." name termcap-file))))))
|
|---|
| 47 |
|
|---|
| 48 | (declaim (inline termcap))
|
|---|
| 49 | (defun termcap (name termcap)
|
|---|
| 50 | (cdr (assoc name termcap :test #'eq)))
|
|---|
| 51 |
|
|---|
| 52 |
|
|---|
| 53 | |
|---|
| 54 |
|
|---|
| 55 | ;;;; Finding the termcap entry
|
|---|
| 56 |
|
|---|
| 57 | (defun find-termcap-entry (name stream)
|
|---|
| 58 | (loop
|
|---|
| 59 | (let ((end-of-names (lex-termcap-name stream)))
|
|---|
| 60 | (when (termcap-found-p name)
|
|---|
| 61 | (unless end-of-names (skip-termcap-names stream))
|
|---|
| 62 | (return t))
|
|---|
| 63 | (when end-of-names
|
|---|
| 64 | (unless (skip-termcap-fields stream)
|
|---|
| 65 | (return nil))))))
|
|---|
| 66 |
|
|---|
| 67 |
|
|---|
| 68 | ;;; This buffer is used in LEX-TERMCAP-NAME and PARSE-FIELDS to
|
|---|
| 69 | ;;; do string comparisons and build strings from interpreted termcap
|
|---|
| 70 | ;;; characters, respectively.
|
|---|
| 71 | ;;;
|
|---|
| 72 | (defvar *termcap-string-buffer* (make-string 300))
|
|---|
| 73 | (defvar *termcap-string-index* 0)
|
|---|
| 74 |
|
|---|
| 75 | (eval-when (:compile-toplevel :execute)
|
|---|
| 76 |
|
|---|
| 77 | (defmacro init-termcap-string-buffer ()
|
|---|
| 78 | `(setf *termcap-string-index* 0))
|
|---|
| 79 |
|
|---|
| 80 | (defmacro store-char (char)
|
|---|
| 81 | `(progn
|
|---|
| 82 | (setf (schar *termcap-string-buffer* *termcap-string-index*) ,char)
|
|---|
| 83 | (incf *termcap-string-index*)))
|
|---|
| 84 |
|
|---|
| 85 | (defmacro termcap-string-buffer-string ()
|
|---|
| 86 | `(subseq (the simple-string *termcap-string-buffer*)
|
|---|
| 87 | 0 *termcap-string-index*))
|
|---|
| 88 |
|
|---|
| 89 | ) ;eval-when
|
|---|
| 90 |
|
|---|
| 91 |
|
|---|
| 92 | ;;; LEX-TERMCAP-NAME gathers characters until the next #\|, which separate
|
|---|
| 93 | ;;; terminal names, or #\:, which terminate terminal names for an entry.
|
|---|
| 94 | ;;; T is returned if the end of the names is reached for the entry.
|
|---|
| 95 | ;;; If we hit and EOF, act like we found a :.
|
|---|
| 96 | ;;;
|
|---|
| 97 | (defun lex-termcap-name (stream)
|
|---|
| 98 | (init-termcap-string-buffer)
|
|---|
| 99 | (loop
|
|---|
| 100 | (let ((char (read-char stream nil #\:)))
|
|---|
| 101 | (case char
|
|---|
| 102 | (#\Linefeed (init-termcap-string-buffer))
|
|---|
| 103 | (#\# (read-line stream nil))
|
|---|
| 104 | (#\| (return nil))
|
|---|
| 105 | (#\: (return t))
|
|---|
| 106 | (t (store-char char))))))
|
|---|
| 107 |
|
|---|
| 108 | (defun termcap-found-p (name)
|
|---|
| 109 | (string= name *termcap-string-buffer* :end2 *termcap-string-index*))
|
|---|
| 110 |
|
|---|
| 111 | ;;; SKIP-TERMCAP-NAMES eats characters until the next #\: which terminates
|
|---|
| 112 | ;;; terminal names for an entry. Stop also at EOF.
|
|---|
| 113 | ;;;
|
|---|
| 114 | (defun skip-termcap-names (stream)
|
|---|
| 115 | (loop
|
|---|
| 116 | (when (char= (read-char stream nil #\:) #\:)
|
|---|
| 117 | (return))))
|
|---|
| 118 |
|
|---|
| 119 | ;;; SKIP-TERMCAP-FIELDS skips the rest of an entry, returning nil if there
|
|---|
| 120 | ;;; are no more entries in the file. An entry is terminated by a #\:
|
|---|
| 121 | ;;; followed by a #\newline (possibly by eof).
|
|---|
| 122 | ;;;
|
|---|
| 123 | (defun skip-termcap-fields (stream)
|
|---|
| 124 | (loop
|
|---|
| 125 | (multiple-value-bind (line eofp)
|
|---|
| 126 | (read-line stream nil)
|
|---|
| 127 | (if eofp
|
|---|
| 128 | (return nil)
|
|---|
| 129 | (let ((len (length line)))
|
|---|
| 130 | (declare (simple-string line))
|
|---|
| 131 | (when (and (not (zerop len))
|
|---|
| 132 | (not (char= (schar line 0) #\#))
|
|---|
| 133 | (char= (schar line (1- len)) #\:))
|
|---|
| 134 | (let ((char (read-char stream nil :eof)))
|
|---|
| 135 | (if (eq char :eof)
|
|---|
| 136 | (return nil)
|
|---|
| 137 | (unread-char char stream))
|
|---|
| 138 | (return t))))))))
|
|---|
| 139 |
|
|---|
| 140 |
|
|---|
| 141 | |
|---|
| 142 |
|
|---|
| 143 | ;;;; Defining known capabilities for parsing purposes.
|
|---|
| 144 |
|
|---|
| 145 | (eval-when (:compile-toplevel :execute :load-toplevel)
|
|---|
| 146 | (defvar *known-termcaps* ())
|
|---|
| 147 | ) ;eval-when
|
|---|
| 148 |
|
|---|
| 149 |
|
|---|
| 150 | (eval-when (:compile-toplevel :execute)
|
|---|
| 151 |
|
|---|
| 152 | ;;; DEFTERMCAP makes a terminal capability known for parsing purposes.
|
|---|
| 153 | ;;; Type is one of :string, :number, or :boolean. Cl-name is an EQ
|
|---|
| 154 | ;;; identifier for the capability.
|
|---|
| 155 | ;;;
|
|---|
| 156 | (defmacro deftermcap (name type cl-name)
|
|---|
| 157 | `(progn (push (list ,name ,type ,cl-name) *known-termcaps*)))
|
|---|
| 158 |
|
|---|
| 159 | (defmacro termcap-def (name)
|
|---|
| 160 | `(cdr (assoc ,name *known-termcaps* :test #'string=)))
|
|---|
| 161 |
|
|---|
| 162 | (defmacro termcap-def-type (termcap-def)
|
|---|
| 163 | `(car ,termcap-def))
|
|---|
| 164 |
|
|---|
| 165 | (defmacro termcap-def-cl-name (termcap-def)
|
|---|
| 166 | `(cadr ,termcap-def))
|
|---|
| 167 |
|
|---|
| 168 | ) ;eval-when
|
|---|
| 169 |
|
|---|
| 170 |
|
|---|
| 171 | (deftermcap "is" :string :init-string)
|
|---|
| 172 | (deftermcap "if" :string :init-file)
|
|---|
| 173 | (deftermcap "ti" :string :init-cursor-motion)
|
|---|
| 174 | (deftermcap "te" :string :end-cursor-motion)
|
|---|
| 175 | (deftermcap "al" :string :open-line)
|
|---|
| 176 | (deftermcap "am" :boolean :auto-margins-p)
|
|---|
| 177 | (deftermcap "ce" :string :clear-to-eol)
|
|---|
| 178 | (deftermcap "cl" :string :clear-display)
|
|---|
| 179 | (deftermcap "cm" :string :cursor-motion)
|
|---|
| 180 | (deftermcap "co" :number :columns)
|
|---|
| 181 | (deftermcap "dc" :string :delete-char)
|
|---|
| 182 | (deftermcap "dm" :string :init-delete-mode)
|
|---|
| 183 | (deftermcap "ed" :string :end-delete-mode)
|
|---|
| 184 | (deftermcap "dl" :string :delete-line)
|
|---|
| 185 | (deftermcap "im" :string :init-insert-mode)
|
|---|
| 186 | (deftermcap "ic" :string :init-insert-char)
|
|---|
| 187 | (deftermcap "ip" :string :end-insert-char)
|
|---|
| 188 | (deftermcap "ei" :string :end-insert-mode)
|
|---|
| 189 | (deftermcap "li" :number :lines)
|
|---|
| 190 | (deftermcap "so" :string :init-standout-mode)
|
|---|
| 191 | (deftermcap "se" :string :end-standout-mode)
|
|---|
| 192 | (deftermcap "tc" :string :similar-terminal)
|
|---|
| 193 | (deftermcap "os" :boolean :overstrikes)
|
|---|
| 194 | (deftermcap "ul" :boolean :underlines)
|
|---|
| 195 |
|
|---|
| 196 | ;;; font related stuff, added by William
|
|---|
| 197 | (deftermcap "ae" :string :end-alternate-char-set)
|
|---|
| 198 | (deftermcap "as" :string :start-alternate-char-set)
|
|---|
| 199 | (deftermcap "mb" :string :start-blinking-attribute)
|
|---|
| 200 | (deftermcap "md" :string :start-bold-attribute)
|
|---|
| 201 | (deftermcap "me" :string :end-all-attributes)
|
|---|
| 202 | (deftermcap "mh" :string :start-half-bright-attribute)
|
|---|
| 203 | (deftermcap "mk" :string :start-blank-attribute)
|
|---|
| 204 | (deftermcap "mp" :string :start-protected-attribute)
|
|---|
| 205 | (deftermcap "mr" :string :start-reverse-video-attribute)
|
|---|
| 206 | (deftermcap "ue" :string :end-underscore-mode)
|
|---|
| 207 | (deftermcap "us" :string :start-underscore-mode)
|
|---|
| 208 |
|
|---|
| 209 | |
|---|
| 210 |
|
|---|
| 211 | ;;;; Parsing an entry.
|
|---|
| 212 |
|
|---|
| 213 | (defvar *getchar-ungetchar-buffer* nil)
|
|---|
| 214 |
|
|---|
| 215 | (eval-when (:compile-toplevel :execute)
|
|---|
| 216 |
|
|---|
| 217 | ;;; UNGETCHAR -- Internal.
|
|---|
| 218 | ;;;
|
|---|
| 219 | ;;; We need this to be able to peek ahead more than one character.
|
|---|
| 220 | ;;; This is used in PARSE-FIELDS and GET-TERMCAP-STRING-CHAR.
|
|---|
| 221 | ;;;
|
|---|
| 222 | (defmacro ungetchar (char)
|
|---|
| 223 | `(push ,char *getchar-ungetchar-buffer*))
|
|---|
| 224 |
|
|---|
| 225 | ;;; GETCHAR -- Internal.
|
|---|
| 226 | ;;;
|
|---|
| 227 | ;;; This is used in PARSE-FIELDS and GET-TERMCAP-STRING-CHAR.
|
|---|
| 228 | ;;;
|
|---|
| 229 | (defmacro getchar ()
|
|---|
| 230 | `(loop
|
|---|
| 231 | (setf char
|
|---|
| 232 | (if *getchar-ungetchar-buffer*
|
|---|
| 233 | (pop *getchar-ungetchar-buffer*)
|
|---|
| 234 | (read-char stream nil :eof)))
|
|---|
| 235 | (if (and (characterp char) (char= char #\\))
|
|---|
| 236 | (let ((temp (if *getchar-ungetchar-buffer*
|
|---|
| 237 | (pop *getchar-ungetchar-buffer*)
|
|---|
| 238 | (read-char stream))))
|
|---|
| 239 | (when (char/= temp #\newline)
|
|---|
| 240 | (ungetchar temp)
|
|---|
| 241 | (return char)))
|
|---|
| 242 | (return char))))
|
|---|
| 243 |
|
|---|
| 244 |
|
|---|
| 245 | ;;; STORE-FIELD used in PARSE-FIELDS.
|
|---|
| 246 | ;;;
|
|---|
| 247 | (defmacro store-field (cl-name value)
|
|---|
| 248 | (let ((name (gensym)))
|
|---|
| 249 | `(let ((,name ,cl-name))
|
|---|
| 250 | (unless (cdr (assoc ,name termcap :test #'eq))
|
|---|
| 251 | (push (cons ,name ,value) termcap)))))
|
|---|
| 252 |
|
|---|
| 253 | ) ;eval-when
|
|---|
| 254 |
|
|---|
| 255 | ;;; PARSE-FIELDS parses a termcap entry. We start out in the state get-name.
|
|---|
| 256 | ;;; Each name is looked up in *known-termcaps*, and if it is of interest, then
|
|---|
| 257 | ;;; we dispatch to a state to pick up the value of the field; otherwise, eat
|
|---|
| 258 | ;;; the rest of the field to get to the next name. The name could be present
|
|---|
| 259 | ;;; simply to have the capability negated before the entry indirects to a
|
|---|
| 260 | ;;; similar terminal's capabilities, in which case it is followed by an #\@.
|
|---|
| 261 | ;;; Negated fields are stored with the value :negated since we only store a
|
|---|
| 262 | ;;; field if it does not already have a value -- this is the intent of the
|
|---|
| 263 | ;;; sequencing built into the termcap file. When we are done, we see if there
|
|---|
| 264 | ;;; is a similar terminal to be parsed, and when we are really done, we replace
|
|---|
| 265 | ;;; all the :negated's with nil's.
|
|---|
| 266 | ;;;
|
|---|
| 267 | (defun parse-fields (stream)
|
|---|
| 268 | (prog ((termcap-name (make-string 2))
|
|---|
| 269 | (termcap ())
|
|---|
| 270 | char termcap-def)
|
|---|
| 271 | GET-NAME
|
|---|
| 272 | ;;
|
|---|
| 273 | ;; This state expects char to be a #\:.
|
|---|
| 274 | (case (getchar)
|
|---|
| 275 | ((#\space #\tab)
|
|---|
| 276 | (go GET-NAME))
|
|---|
| 277 | (#\:
|
|---|
| 278 | ;; This is an empty field.
|
|---|
| 279 | (go GET-NAME))
|
|---|
| 280 | ((#\newline :eof)
|
|---|
| 281 | (go MAYBE-DONE))
|
|---|
| 282 | (t
|
|---|
| 283 | (setf (schar termcap-name 0) char)))
|
|---|
| 284 | (setf (schar termcap-name 1) (getchar))
|
|---|
| 285 | (setf termcap-def (termcap-def termcap-name))
|
|---|
| 286 | (unless termcap-def (go EAT-FIELD))
|
|---|
| 287 | (when (char= (getchar) #\@)
|
|---|
| 288 | ;; Negation of a capability to be inherited from a similar terminal.
|
|---|
| 289 | (store-field (termcap-def-cl-name termcap-def) :negated)
|
|---|
| 290 | (go EAT-FIELD))
|
|---|
| 291 | (case (termcap-def-type termcap-def)
|
|---|
| 292 | (:number (go NUMBER))
|
|---|
| 293 | (:boolean (go BOOLEAN))
|
|---|
| 294 | (:string (go STRING)))
|
|---|
| 295 | NUMBER
|
|---|
| 296 | (unless (char= char #\#)
|
|---|
| 297 | (error "Bad termcap format -- number field '#' missing."))
|
|---|
| 298 | (let ((number 0)
|
|---|
| 299 | digit)
|
|---|
| 300 | (loop
|
|---|
| 301 | (setf digit (digit-char-p (getchar)))
|
|---|
| 302 | (if digit
|
|---|
| 303 | (setf number (+ digit (* number 10)))
|
|---|
| 304 | (if (char= char #\:)
|
|---|
| 305 | (return)
|
|---|
| 306 | (error "Bad termcap format -- number field not : terminated."))))
|
|---|
| 307 | (store-field (termcap-def-cl-name termcap-def) number)
|
|---|
| 308 | (go GET-NAME))
|
|---|
| 309 | BOOLEAN
|
|---|
| 310 | (store-field (termcap-def-cl-name termcap-def) t)
|
|---|
| 311 | (if (char= char #\:)
|
|---|
| 312 | (go GET-NAME)
|
|---|
| 313 | (error "Bad termcap format -- boolean field not : terminated."))
|
|---|
| 314 | STRING
|
|---|
| 315 | (unless (char= char #\=)
|
|---|
| 316 | (error "Bad termcap format -- string field '=' missing."))
|
|---|
| 317 | ;;
|
|---|
| 318 | ;; Eat up any cost of the capability.
|
|---|
| 319 | (when (digit-char-p (getchar))
|
|---|
| 320 | (let ((dotp nil))
|
|---|
| 321 | (loop
|
|---|
| 322 | (case (getchar)
|
|---|
| 323 | ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
|
|---|
| 324 | (#\.
|
|---|
| 325 | (when dotp (return))
|
|---|
| 326 | (setf dotp t))
|
|---|
| 327 | (t (when (char= char #\*) (getchar)) ; '*' means a per line cost
|
|---|
| 328 | (return))))))
|
|---|
| 329 | ;;
|
|---|
| 330 | ;; Collect the characters.
|
|---|
| 331 | (let ((normal-string-p (not (eq (termcap-def-cl-name termcap-def)
|
|---|
| 332 | :cursor-motion)))
|
|---|
| 333 | xp cm-info)
|
|---|
| 334 | (init-termcap-string-buffer)
|
|---|
| 335 | (loop
|
|---|
| 336 | (case (setf char (get-termcap-string-char stream char))
|
|---|
| 337 | (#\%
|
|---|
| 338 | (if normal-string-p
|
|---|
| 339 | (store-char #\%)
|
|---|
| 340 | (case (getchar)
|
|---|
| 341 | (#\% (store-char #\%))
|
|---|
| 342 | ((#\d #\2 #\3)
|
|---|
| 343 | (push (if (char= char #\d) 0 (digit-char-p char))
|
|---|
| 344 | cm-info)
|
|---|
| 345 | (push (if xp :y-pad :x-pad) cm-info)
|
|---|
| 346 | (push (termcap-string-buffer-string) cm-info)
|
|---|
| 347 | (push (if xp :string2 :string1) cm-info)
|
|---|
| 348 | (init-termcap-string-buffer)
|
|---|
| 349 | (setf xp t))
|
|---|
| 350 | (#\.
|
|---|
| 351 | (push (termcap-string-buffer-string) cm-info)
|
|---|
| 352 | (push (if xp :string2 :string1) cm-info)
|
|---|
| 353 | (init-termcap-string-buffer)
|
|---|
| 354 | (setf xp t))
|
|---|
| 355 | (#\+
|
|---|
| 356 | (push (termcap-string-buffer-string) cm-info)
|
|---|
| 357 | (push (if xp :string2 :string1) cm-info)
|
|---|
| 358 | (push (get-termcap-string-char stream (getchar)) cm-info)
|
|---|
| 359 | (push (if xp :y-add-char :x-add-char) cm-info)
|
|---|
| 360 | (init-termcap-string-buffer)
|
|---|
| 361 | (setf xp t))
|
|---|
| 362 | (#\>
|
|---|
| 363 | (push (get-termcap-string-char stream (getchar)) cm-info)
|
|---|
| 364 | (push (if xp :y-condx-char :x-condx-char) cm-info)
|
|---|
| 365 | (push (get-termcap-string-char stream (getchar)) cm-info)
|
|---|
| 366 | (push (if xp :y-condx-add-char :x-condx-add-char) cm-info))
|
|---|
| 367 | (#\r
|
|---|
| 368 | (push t cm-info)
|
|---|
| 369 | (push :reversep cm-info))
|
|---|
| 370 | (#\i
|
|---|
| 371 | (push t cm-info)
|
|---|
| 372 | (push :one-origin cm-info)))))
|
|---|
| 373 | (#\:
|
|---|
| 374 | (store-field (termcap-def-cl-name termcap-def)
|
|---|
| 375 | (cond (normal-string-p (termcap-string-buffer-string))
|
|---|
| 376 | (t (push (termcap-string-buffer-string) cm-info)
|
|---|
| 377 | (cons :string3 cm-info))))
|
|---|
| 378 | (return))
|
|---|
| 379 | (t (store-char char)))
|
|---|
| 380 | (getchar))
|
|---|
| 381 | (go GET-NAME))
|
|---|
| 382 | EAT-FIELD
|
|---|
| 383 | (loop (when (char= (getchar) #\:) (return)))
|
|---|
| 384 | (go GET-NAME)
|
|---|
| 385 | MAYBE-DONE
|
|---|
| 386 | (let* ((similar-terminal (assoc :similar-terminal termcap :test #'eq))
|
|---|
| 387 | (name (cdr similar-terminal)))
|
|---|
| 388 | (when name
|
|---|
| 389 | (file-position stream :start)
|
|---|
| 390 | (setf (cdr similar-terminal) nil)
|
|---|
| 391 | (if (find-termcap-entry name stream)
|
|---|
| 392 | (go GET-NAME)
|
|---|
| 393 | (error "Unknown similar terminal name -- ~S." name))))
|
|---|
| 394 | (dolist (ele termcap)
|
|---|
| 395 | (when (eq (cdr ele) :negated)
|
|---|
| 396 | (setf (cdr ele) nil)))
|
|---|
| 397 | (return termcap)))
|
|---|
| 398 |
|
|---|
| 399 | ;;; GET-TERMCAP-STRING-CHAR -- Internal.
|
|---|
| 400 | ;;;
|
|---|
| 401 | ;;; This parses/lexes an ASCII character out of the termcap file and converts
|
|---|
| 402 | ;;; it into the appropriate Common Lisp character. This is a Common Lisp
|
|---|
| 403 | ;;; character with the same CHAR-CODE code as the ASCII code, so writing the
|
|---|
| 404 | ;;; character to the tty will have the desired effect. If this function needs
|
|---|
| 405 | ;;; to look ahead to determine any characters, it unreads the character.
|
|---|
| 406 | ;;;
|
|---|
| 407 | (defun get-termcap-string-char (stream char)
|
|---|
| 408 | (case char
|
|---|
| 409 | (#\\
|
|---|
| 410 | (case (getchar)
|
|---|
| 411 | (#\E (code-char 27))
|
|---|
| 412 | (#\n (code-char 10))
|
|---|
| 413 | (#\r (code-char 13))
|
|---|
| 414 | (#\t (code-char 9))
|
|---|
| 415 | (#\b (code-char 8))
|
|---|
| 416 | (#\f (code-char 12))
|
|---|
| 417 | (#\^ #\^)
|
|---|
| 418 | (#\\ #\\)
|
|---|
| 419 | ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|---|
| 420 | (let ((result 0)
|
|---|
| 421 | (digit (digit-char-p char)))
|
|---|
| 422 | (loop (setf result (+ digit (* 8 result)))
|
|---|
| 423 | (unless (setf digit (digit-char-p (getchar)))
|
|---|
| 424 | (ungetchar char)
|
|---|
| 425 | (return (code-char (ldb (byte 7 0) result)))))))
|
|---|
| 426 | (t (error "Bad termcap format -- unknown backslash character."))))
|
|---|
| 427 | (#\^
|
|---|
| 428 | (code-char (- (char-code (char-upcase (getchar))) 64)))
|
|---|
| 429 | (t char)))
|
|---|
| 430 |
|
|---|
| 431 | |
|---|
| 432 |
|
|---|
| 433 | ;;;; Initialization file string.
|
|---|
| 434 |
|
|---|
| 435 | (defun get-init-file-string (f)
|
|---|
| 436 | (unless (probe-file f)
|
|---|
| 437 | (error "File containing terminal initialization string does not exist -- ~S."
|
|---|
| 438 | f))
|
|---|
| 439 | (with-open-file (s f)
|
|---|
| 440 | (let* ((len (file-length s))
|
|---|
| 441 | (string (make-string len)))
|
|---|
| 442 | (dotimes (i len string)
|
|---|
| 443 | (setf (schar string i) (read-char s))))))
|
|---|
