[Linedit-cvs] CVS update: src/terminfo.asd src/terminfo.lisp src/Makefile
Nikodemus Siivola
nsiivola at common-lisp.net
Mon Oct 20 07:49:25 UTC 2003
Update of /project/linedit/cvsroot/src
In directory common-lisp.net:/tmp/cvs-serv15949
Modified Files:
Makefile
Added Files:
terminfo.asd terminfo.lisp
Log Message:
Added terminfo as a separate system.
Date: Mon Oct 20 03:49:25 2003
Author: nsiivola
Index: src/terminfo.lisp
diff -u /dev/null src/terminfo.lisp:1.4
--- /dev/null Mon Oct 20 03:49:25 2003
+++ src/terminfo.lisp Mon Oct 20 03:49:24 2003
@@ -0,0 +1,867 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: TERMINFO -*-
+
+;;; $Revision: 1.4 $
+;;; Copyright © 2001 Paul Foley (mycroft at actrix.gen.nz)
+;;; All rights reserved. Use and verbatim redistribution permitted.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;;; DAMAGE.
+#+CMU (ext:file-comment "$Header: /project/linedit/cvsroot/src/terminfo.lisp,v 1.4 2003/10/20 07:49:24 nsiivola Exp $")
+
+(in-package "CL-USER")
+
+;; DEFPACKAGE would warn here, since we export things outside the
+;; definition.
+(eval-when (:compile-toplevel :load-toplevel)
+ (unless (find-package "TERMINFO")
+ (make-package "TERMINFO" :nicknames '("TI") :use '("CL"))))
+
+(in-package "TERMINFO")
+
+(export '(*terminfo-directory* *terminfo* capability tparm
+ tputs set-terminal))
+
+(defvar *terminfo-directory* "/usr/share/terminfo/")
+
+(defvar *terminfo* nil)
+
+(defvar *capabilities* (make-hash-table :size 494))
+
+(flet ((required-argument ()
+ (error "A required argument was not supplied.")))
+ (defstruct (terminfo
+ (:print-function
+ (lambda (object stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "~A" (first (terminfo-names object)))))))
+ (names (required-argument) :type list :read-only t)
+ (booleans (required-argument) :type (simple-array (member t nil) (*)))
+ (numbers (required-argument) :type (simple-array (signed-byte 16) (*)))
+ (strings (required-argument) :type (simple-array t (*)))))
+
+(defun capability (name &optional (terminfo *terminfo*))
+ (let ((whatsit (gethash name *capabilities*)))
+ (if (or (null terminfo) (>= (cdr whatsit)
+ (length (funcall (car whatsit) terminfo))))
+ nil #| default |#
+ (let ((value (aref (funcall (car whatsit) terminfo) (cdr whatsit))))
+ (if (and (numberp value) (minusp value))
+ nil
+ value)))))
+
+(defmacro defcap (name type index)
+ (let ((thing (ecase type
+ (boolean 'terminfo-booleans)
+ (integer 'terminfo-numbers)
+ (string 'terminfo-strings))))
+ `(progn
+ (setf (gethash ,(intern (string name) "KEYWORD") *capabilities*)
+ (cons #',thing ,index))
+ (define-symbol-macro ,name
+ (capability ,(intern (string name) "KEYWORD") *terminfo*))
+ (export ',name "TERMINFO"))))
+
+(defcap auto-left-margin boolean 0)
+(defcap auto-right-margin boolean 1)
+(defcap no-esc-ctlc boolean 2)
+(defcap ceol-standout-glitch boolean 3)
+(defcap eat-newline-glitch boolean 4)
+(defcap erase-overstrike boolean 5)
+(defcap generic-type boolean 6)
+(defcap hard-copy boolean 7)
+(defcap has-meta-key boolean 8)
+(defcap has-status-line boolean 9)
+(defcap insert-null-glitch boolean 10)
+(defcap memory-above boolean 11)
+(defcap memory-below boolean 12)
+(defcap move-insert-mode boolean 13)
+(defcap move-standout-mode boolean 14)
+(defcap over-strike boolean 15)
+(defcap status-line-esc-ok boolean 16)
+(defcap dest-tabs-magic-smso boolean 17)
+(defcap tilde-glitch boolean 18)
+(defcap transparent-underline boolean 19)
+(defcap xon-xoff boolean 20)
+(defcap needs-xon-xoff boolean 21)
+(defcap prtr-silent boolean 22)
+(defcap hard-cursor boolean 23)
+(defcap non-rev-rmcup boolean 24)
+(defcap no-pad-char boolean 25)
+(defcap non-dest-scroll-region boolean 26)
+(defcap can-change boolean 27)
+(defcap back-color-erase boolean 28)
+(defcap hue-lightness-saturation boolean 29)
+(defcap col-addr-glitch boolean 30)
+(defcap cr-cancels-micro-mode boolean 31)
+(defcap has-print-wheel boolean 32)
+(defcap row-addr-glitch boolean 33)
+(defcap semi-auto-right-margin boolean 34)
+(defcap cpi-changes-res boolean 35)
+(defcap lpi-changes-res boolean 36)
+
+(defcap columns integer 0)
+(defcap init-tabs integer 1)
+(defcap lines integer 2)
+(defcap lines-of-memory integer 3)
+(defcap magic-cookie-glitch integer 4)
+(defcap padding-baud-rate integer 5)
+(defcap virtual-terminal integer 6)
+(defcap width-status-line integer 7)
+(defcap num-labels integer 8)
+(defcap label-height integer 9)
+(defcap label-width integer 10)
+(defcap max-attributes integer 11)
+(defcap maximum-windows integer 12)
+(defcap max-colors integer 13)
+(defcap max-pairs integer 14)
+(defcap no-color-video integer 15)
+(defcap buffer-capacity integer 16)
+(defcap dot-vert-spacing integer 17)
+(defcap dot-horz-spacing integer 18)
+(defcap max-micro-address integer 19)
+(defcap max-micro-jump integer 20)
+(defcap micro-col-size integer 21)
+(defcap micro-line-size integer 22)
+(defcap number-of-pins integer 23)
+(defcap output-res-char integer 24)
+(defcap output-res-line integer 25)
+(defcap output-res-horz-inch integer 26)
+(defcap output-res-vert-inch integer 27)
+(defcap print-rate integer 28)
+(defcap wide-char-size integer 29)
+(defcap buttons integer 30)
+(defcap bit-image-entwining integer 31)
+(defcap bit-image-type integer 32)
+
+(defcap back-tab string 0)
+(defcap bell string 1)
+(defcap carriage-return string 2)
+(defcap change-scroll-region string 3)
+(defcap clear-all-tabs string 4)
+(defcap clear-screen string 5)
+(defcap clr-eol string 6)
+(defcap clr-eos string 7)
+(defcap column-address string 8)
+(defcap command-character string 9)
+(defcap cursor-address string 10)
+(defcap cursor-down string 11)
+(defcap cursor-home string 12)
+(defcap cursor-invisible string 13)
+(defcap cursor-left string 14)
+(defcap cursor-mem-address string 15)
+(defcap cursor-normal string 16)
+(defcap cursor-right string 17)
+(defcap cursor-to-ll string 18)
+(defcap cursor-up string 19)
+(defcap cursor-visible string 20)
+(defcap delete-character string 21)
+(defcap delete-line string 22)
+(defcap dis-status-line string 23)
+(defcap down-half-line string 24)
+(defcap enter-alt-charset-mode string 25)
+(defcap enter-blink-mode string 26)
+(defcap enter-bold-mode string 27)
+(defcap enter-ca-mode string 28)
+(defcap enter-delete-mode string 29)
+(defcap enter-dim-mode string 30)
+(defcap enter-insert-mode string 31)
+(defcap enter-secure-mode string 32)
+(defcap enter-protected-mode string 33)
+(defcap enter-reverse-mode string 34)
+(defcap enter-standout-mode string 35)
+(defcap enter-underline-mode string 36)
+(defcap erase-chars string 37)
+(defcap exit-alt-charset-mode string 38)
+(defcap exit-attribute-mode string 39)
+(defcap exit-ca-mode string 40)
+(defcap exit-delete-mode string 41)
+(defcap exit-insert-mode string 42)
+(defcap exit-standout-mode string 43)
+(defcap exit-underline-mode string 44)
+(defcap flash-screen string 45)
+(defcap form-feed string 46)
+(defcap from-status-line string 47)
+(defcap init-1string string 48)
+(defcap init-2string string 49)
+(defcap init-3string string 50)
+(defcap init-file string 51)
+(defcap insert-character string 52)
+(defcap insert-line string 53)
+(defcap insert-padding string 54)
+(defcap key-backspace string 55)
+(defcap key-catab string 56)
+(defcap key-clear string 57)
+(defcap key-ctab string 58)
+(defcap key-dc string 59)
+(defcap key-dl string 60)
+(defcap key-down string 61)
+(defcap key-eic string 62)
+(defcap key-eol string 63)
+(defcap key-eos string 64)
+(defcap key-f0 string 65)
+(defcap key-f1 string 66)
+(defcap key-f10 string 67)
+(defcap key-f2 string 68)
+(defcap key-f3 string 69)
+(defcap key-f4 string 70)
+(defcap key-f5 string 71)
+(defcap key-f6 string 72)
+(defcap key-f7 string 73)
+(defcap key-f8 string 74)
+(defcap key-f9 string 75)
+(defcap key-home string 76)
+(defcap key-ic string 77)
+(defcap key-il string 78)
+(defcap key-left string 79)
+(defcap key-ll string 80)
+(defcap key-npage string 81)
+(defcap key-ppage string 82)
+(defcap key-right string 83)
+(defcap key-sf string 84)
+(defcap key-sr string 85)
+(defcap key-stab string 86)
+(defcap key-up string 87)
+(defcap keypad-local string 88)
+(defcap keypad-xmit string 89)
+(defcap lab-f0 string 90)
+(defcap lab-f1 string 91)
+(defcap lab-f10 string 92)
+(defcap lab-f2 string 93)
+(defcap lab-f3 string 94)
+(defcap lab-f4 string 95)
+(defcap lab-f5 string 96)
+(defcap lab-f6 string 97)
+(defcap lab-f7 string 98)
+(defcap lab-f8 string 99)
+(defcap lab-f9 string 100)
+(defcap meta-off string 101)
+(defcap meta-on string 102)
+(defcap newline string 103)
+(defcap pad-char string 104)
+(defcap parm-dch string 105)
+(defcap parm-delete-line string 106)
+(defcap parm-down-cursor string 107)
+(defcap parm-ich string 108)
+(defcap parm-index string 109)
+(defcap parm-insert-line string 110)
+(defcap parm-left-cursor string 111)
+(defcap parm-right-cursor string 112)
+(defcap parm-rindex string 113)
+(defcap parm-up-cursor string 114)
+(defcap pkey-key string 115)
+(defcap pkey-local string 116)
+(defcap pkey-xmit string 117)
+(defcap print-screen string 118)
+(defcap prtr-off string 119)
+(defcap prtr-on string 120)
+(defcap repeat-char string 121)
+(defcap reset-1string string 122)
+(defcap reset-2string string 123)
+(defcap reset-3string string 124)
+(defcap reset-file string 125)
+(defcap restore-cursor string 126)
+(defcap row-address string 127)
+(defcap save-cursor string 128)
+(defcap scroll-forward string 129)
+(defcap scroll-reverse string 130)
+(defcap set-attributes string 131)
+(defcap set-tab string 132)
+(defcap set-window string 133)
+(defcap tab string 134)
+(defcap to-status-line string 135)
+(defcap underline-char string 136)
+(defcap up-half-line string 137)
+(defcap init-prog string 138)
+(defcap key-a1 string 139)
+(defcap key-a3 string 140)
+(defcap key-b2 string 141)
+(defcap key-c1 string 142)
+(defcap key-c3 string 143)
+(defcap prtr-non string 144)
+(defcap char-padding string 145)
+(defcap acs-chars string 146)
+(defcap plab-norm string 147)
+(defcap key-btab string 148)
+(defcap enter-xon-mode string 149)
+(defcap exit-xon-mode string 150)
+(defcap enter-am-mode string 151)
+(defcap exit-am-mode string 152)
+(defcap xon-character string 153)
+(defcap xoff-character string 154)
+(defcap ena-acs string 155)
+(defcap label-on string 156)
+(defcap label-off string 157)
+(defcap key-beg string 158)
+(defcap key-cancel string 159)
+(defcap key-close string 160)
+(defcap key-command string 161)
+(defcap key-copy string 162)
+(defcap key-create string 163)
+(defcap key-end string 164)
+(defcap key-enter string 165)
+(defcap key-exit string 166)
+(defcap key-find string 167)
+(defcap key-help string 168)
+(defcap key-mark string 169)
+(defcap key-message string 170)
+(defcap key-move string 171)
+(defcap key-next string 172)
+(defcap key-open string 173)
+(defcap key-options string 174)
+(defcap key-previous string 175)
+(defcap key-print string 176)
+(defcap key-redo string 177)
+(defcap key-reference string 178)
+(defcap key-refresh string 179)
+(defcap key-replace string 180)
+(defcap key-restart string 181)
+(defcap key-resume string 182)
+(defcap key-save string 183)
+(defcap key-suspend string 184)
+(defcap key-undo string 185)
+(defcap key-sbeg string 186)
+(defcap key-scancel string 187)
+(defcap key-scommand string 188)
+(defcap key-scopy string 189)
+(defcap key-screate string 190)
+(defcap key-sdc string 191)
+(defcap key-sdl string 192)
+(defcap key-select string 193)
+(defcap key-send string 194)
+(defcap key-seol string 195)
+(defcap key-sexit string 196)
+(defcap key-sfind string 197)
+(defcap key-shelp string 198)
+(defcap key-shome string 199)
+(defcap key-sic string 200)
+(defcap key-sleft string 201)
+(defcap key-smessage string 202)
+(defcap key-smove string 203)
+(defcap key-snext string 204)
+(defcap key-soptions string 205)
+(defcap key-sprevious string 206)
+(defcap key-sprint string 207)
+(defcap key-sredo string 208)
+(defcap key-sreplace string 209)
+(defcap key-sright string 210)
+(defcap key-srsume string 211)
+(defcap key-ssave string 212)
+(defcap key-ssuspend string 213)
+(defcap key-sundo string 214)
+(defcap req-for-input string 215)
+(defcap key-f11 string 216)
+(defcap key-f12 string 217)
+(defcap key-f13 string 218)
+(defcap key-f14 string 219)
+(defcap key-f15 string 220)
+(defcap key-f16 string 221)
+(defcap key-f17 string 222)
+(defcap key-f18 string 223)
+(defcap key-f19 string 224)
+(defcap key-f20 string 225)
+(defcap key-f21 string 226)
+(defcap key-f22 string 227)
+(defcap key-f23 string 228)
+(defcap key-f24 string 229)
+(defcap key-f25 string 230)
+(defcap key-f26 string 231)
+(defcap key-f27 string 232)
+(defcap key-f28 string 233)
+(defcap key-f29 string 234)
+(defcap key-f30 string 235)
+(defcap key-f31 string 236)
+(defcap key-f32 string 237)
+(defcap key-f33 string 238)
+(defcap key-f34 string 239)
+(defcap key-f35 string 240)
+(defcap key-f36 string 241)
+(defcap key-f37 string 242)
+(defcap key-f38 string 243)
+(defcap key-f39 string 244)
+(defcap key-f40 string 245)
+(defcap key-f41 string 246)
+(defcap key-f42 string 247)
+(defcap key-f43 string 248)
+(defcap key-f44 string 249)
+(defcap key-f45 string 250)
+(defcap key-f46 string 251)
+(defcap key-f47 string 252)
+(defcap key-f48 string 253)
+(defcap key-f49 string 254)
+(defcap key-f50 string 255)
+(defcap key-f51 string 256)
+(defcap key-f52 string 257)
+(defcap key-f53 string 258)
+(defcap key-f54 string 259)
+(defcap key-f55 string 260)
+(defcap key-f56 string 261)
+(defcap key-f57 string 262)
+(defcap key-f58 string 263)
+(defcap key-f59 string 264)
+(defcap key-f60 string 265)
+(defcap key-f61 string 266)
+(defcap key-f62 string 267)
+(defcap key-f63 string 268)
+(defcap clr-bol string 269)
+(defcap clear-margins string 270)
+(defcap set-left-margin string 271)
+(defcap set-right-margin string 272)
+(defcap label-format string 273)
+(defcap set-clock string 274)
+(defcap display-clock string 275)
+(defcap remove-clock string 276)
+(defcap create-window string 277)
+(defcap goto-window string 278)
+(defcap hangup string 279)
+(defcap dial-phone string 280)
+(defcap quick-dial string 281)
+(defcap tone string 282)
+(defcap pulse string 283)
+(defcap flash-hook string 284)
+(defcap fixed-pause string 285)
+(defcap wait-tone string 286)
+(defcap user0 string 287)
+(defcap user1 string 288)
+(defcap user2 string 289)
+(defcap user3 string 290)
+(defcap user4 string 291)
+(defcap user5 string 292)
+(defcap user6 string 293)
+(defcap user7 string 294)
+(defcap user8 string 295)
+(defcap user9 string 296)
+(defcap orig-pair string 297)
+(defcap orig-colors string 298)
+(defcap initialize-color string 299)
+(defcap initialize-pair string 300)
+(defcap set-color-pair string 301)
+(defcap set-foreground string 302)
+(defcap set-background string 303)
+(defcap change-char-pitch string 304)
+(defcap change-line-pitch string 305)
+(defcap change-res-horz string 306)
+(defcap change-res-vert string 307)
+(defcap define-char string 308)
+(defcap enter-doublewide-mode string 309)
+(defcap enter-draft-quality string 310)
+(defcap enter-italics-mode string 311)
+(defcap enter-leftward-mode string 312)
+(defcap enter-micro-mode string 313)
+(defcap enter-near-letter-quality string 314)
+(defcap enter-normal-quality string 315)
+(defcap enter-shadow-mode string 316)
+(defcap enter-subscript-mode string 317)
+(defcap enter-superscript-mode string 318)
+(defcap enter-upward-mode string 319)
+(defcap exit-doublewide-mode string 320)
+(defcap exit-italics-mode string 321)
+(defcap exit-leftward-mode string 322)
+(defcap exit-micro-mode string 323)
+(defcap exit-shadow-mode string 324)
+(defcap exit-subscript-mode string 325)
+(defcap exit-superscript-mode string 326)
+(defcap exit-upward-mode string 327)
+(defcap micro-column-address string 328)
+(defcap micro-down string 329)
+(defcap micro-left string 330)
+(defcap micro-right string 331)
+(defcap micro-row-address string 332)
+(defcap micro-up string 333)
+(defcap order-of-pins string 334)
+(defcap parm-down-micro string 335)
+(defcap parm-left-micro string 336)
+(defcap parm-right-micro string 337)
+(defcap parm-up-micro string 338)
+(defcap select-char-set string 339)
+(defcap set-bottom-margin string 340)
+(defcap set-bottom-margin-parm string 341)
+(defcap set-left-margin-parm string 342)
+(defcap set-right-margin-parm string 343)
+(defcap set-top-margin string 344)
+(defcap set-top-margin-parm string 345)
+(defcap start-bit-image string 346)
+(defcap start-char-set-def string 347)
+(defcap stop-bit-image string 348)
+(defcap stop-char-set-def string 349)
+(defcap subscript-characters string 350)
+(defcap superscript-characters string 351)
+(defcap these-cause-cr string 352)
+(defcap zero-motion string 353)
+(defcap char-set-names string 354)
+(defcap key-mouse string 355)
+(defcap mouse-info string 356)
+(defcap req-mouse-pos string 357)
+(defcap get-mouse string 358)
+(defcap set-a-foreground string 359)
+(defcap set-a-background string 360)
+(defcap pkey-plab string 361)
+(defcap device-type string 362)
+(defcap code-set-init string 363)
+(defcap set0-des-seq string 364)
+(defcap set1-des-seq string 365)
+(defcap set2-des-seq string 366)
+(defcap set3-des-seq string 367)
+(defcap set-lr-margin string 368)
+(defcap set-tb-margin string 369)
+(defcap bit-image-repeat string 370)
+(defcap bit-image-newline string 371)
+(defcap bit-image-carriage-return string 372)
+(defcap color-names string 373)
+(defcap define-bit-image-region string 374)
+(defcap end-bit-image-region string 375)
+(defcap set-color-band string 376)
+(defcap set-page-length string 377)
+(defcap display-pc-char string 378)
+(defcap enter-pc-charset-mode string 379)
+(defcap exit-pc-charset-mode string 380)
+(defcap enter-scancode-mode string 381)
+(defcap exit-scancode-mode string 382)
+(defcap pc-term-options string 383)
+(defcap scancode-escape string 384)
+(defcap alt-scancode-esc string 385)
+(defcap enter-horizontal-hl-mode string 386)
+(defcap enter-left-hl-mode string 387)
+(defcap enter-low-hl-mode string 388)
+(defcap enter-right-hl-mode string 389)
+(defcap enter-top-hl-mode string 390)
+(defcap enter-vertical-hl-mode string 391)
+(defcap set-a-attributes string 392)
+(defcap set-pglen-inch string 393)
+
+;;#+INTERNAL-CAPS-VISIBLE
+(progn
+ (defcap termcap-init2 string 394)
+ (defcap termcap-reset string 395)
+ (defcap magic-cookie-glitch-ul integer 33)
+ (defcap backspaces-with-bs boolean 37)
+ (defcap crt-no-scrolling boolean 38)
+ (defcap no-correctly-working-cr boolean 39)
+ (defcap carriage-return-delay integer 34)
+ (defcap new-line-delay integer 35)
+ (defcap linefeed-if-not-lf string 396)
+ (defcap backspace-if-not-bs string 397)
+ (defcap gnu-has-meta-key boolean 40)
+ (defcap linefeed-is-newline boolean 41)
+ (defcap backspace-delay integer 36)
+ (defcap horizontal-tab-delay integer 37)
+ (defcap number-of-function-keys integer 38)
+ (defcap other-non-function-keys string 398)
+ (defcap arrow-key-map string 399)
+ (defcap has-hardware-tabs boolean 42)
+ (defcap return-does-clr-eol boolean 43)
+ (defcap acs-ulcorner string 400)
+ (defcap acs-llcorner string 401)
+ (defcap acs-urcorner string 402)
+ (defcap acs-lrcorner string 403)
+ (defcap acs-ltee string 404)
+ (defcap acs-rtee string 405)
+ (defcap acs-btee string 406)
+ (defcap acs-ttee string 407)
+ (defcap acs-hline string 408)
+ (defcap acs-vline string 409)
+ (defcap acs-plus string 410)
+ (defcap memory-lock string 411)
+ (defcap memory-unlock string 412)
+ (defcap box-chars-1 string 413))
+
+
+(defun load-terminfo (name)
+ (let ((name (concatenate 'string (list (char name 0) #\/) name)))
+ (dolist (path (list #+CMU "home:.terminfo/"
+ #+Allegro "~/.terminfo/"
+ *terminfo-directory*))
+ (with-open-file (stream (merge-pathnames name path)
+ :direction :input
+ :element-type '(unsigned-byte 8)
+ :if-does-not-exist nil)
+ (when stream
+ (flet ((read-short (stream)
+ (let ((n (+ (read-byte stream) (* 256 (read-byte stream)))))
+ (if (> n 32767)
+ (- n 65536)
+ n)))
+ (read-string (stream)
+ (do ((c (read-byte stream) (read-byte stream))
+ (s '()))
+ ((zerop c) (coerce (nreverse s) 'string))
+ (push (code-char c) s))))
+ (let* ((magic (read-short stream))
+ (sznames (read-short stream))
+ (szbooleans (read-short stream))
+ (sznumbers (read-short stream))
+ (szstrings (read-short stream))
+ (szstringtable (read-short stream))
+ (names (let ((string (read-string stream)))
+ (loop for i = 0 then (1+ j)
+ as j = (position #\| string :start i)
+ collect (subseq string i j) while j)))
+ (booleans (make-array szbooleans
+ :element-type '(or t nil)
+ :initial-element nil))
+ (numbers (make-array sznumbers
+ :element-type '(signed-byte 16)
+ :initial-element -1))
+ (strings (make-array szstrings
+ :element-type '(signed-byte 16)
+ :initial-element -1))
+ (stringtable (make-string szstringtable))
+ (count 0))
+ (unless (= magic #o432)
+ (error "Invalid file format"))
+ (dotimes (i szbooleans)
+ (setf (aref booleans i) (not (zerop (read-byte stream)))))
+ (when (oddp (+ sznames szbooleans))
+ (read-byte stream))
+ (dotimes (i sznumbers)
+ (setf (aref numbers i) (read-short stream)))
+ (dotimes (i szstrings)
+ (unless (minusp (setf (aref strings i) (read-short stream)))
+ (incf count)))
+ #+CMU
+ (read-sequence stringtable stream)
+ #-CMU
+ (dotimes (i szstringtable)
+ (setf (char stringtable i) (code-char (read-byte stream))))
+ (let ((xtrings (make-array szstrings :initial-element nil)))
+ (dotimes (i szstrings)
+ (unless (minusp (aref strings i))
+ (setf (aref xtrings i)
+ (subseq stringtable (aref strings i)
+ (position #\Null stringtable
+ :start (aref strings i))))))
+ (setq strings xtrings))
+ (return (make-terminfo :names names :booleans booleans
+ :numbers numbers :strings strings)))))))))
+
+(defun tparm (string &rest args)
+ (when (null string) (return-from tparm ""))
+ (with-output-to-string (out)
+ (with-input-from-string (in string)
+ (do ((stack '()) (flags 0) (width 0) (precision 0) (number 0)
+ (dvars (make-array 26 :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (svars (load-time-value
+ (make-array 26 :element-type '(unsigned-byte 8)
+ :initial-element 0)))
+ (c (read-char in nil) (read-char in nil)))
+ ((null c))
+ (cond ((char= c #\%)
+ (setq c (read-char in) flags 0 width 0 precision 0)
+ (tagbody
+ state0
+ (case c
+ (#\% (princ c out) (go terminal))
+ (#\: (setq c (read-char in)) (go state2))
+ (#\+ (go state1))
+ (#\- (go state1))
+ (#\# (go state2))
+ (#\Space (go state2))
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (go state3))
+ (#\d (go state5))
+ (#\o (go state6))
+ ((#\X #\x) (go state7))
+ (#\s (go state8))
+ (#\c (princ (code-char (pop stack)) out) (go terminal))
+ (#\p (go state9))
+ (#\P (go state10))
+ (#\g (go state11))
+ (#\' (go state12))
+ (#\{ (go state13))
+ (#\l (push (length (pop stack)) stack) (go terminal))
+ (#\* (push (* (pop stack) (pop stack)) stack)
+ (go terminal))
+ (#\/ (push (/ (pop stack) (pop stack)) stack)
+ (go terminal))
+ (#\m (push (mod (pop stack) (pop stack)) stack)
+ (go terminal))
+ (#\& (push (logand (pop stack) (pop stack)) stack)
+ (go terminal))
+ (#\| (push (logior (pop stack) (pop stack)) stack)
+ (go terminal))
+ (#\^ (push (logxor (pop stack) (pop stack)) stack)
+ (go terminal))
+ (#\= (push (if (= (pop stack) (pop stack)) 1 0) stack)
+ (go terminal))
+ (#\> (push (if (> (pop stack) (pop stack)) 1 0) stack)
+ (go terminal))
+ (#\< (push (if (< (pop stack) (pop stack)) 1 0) stack)
+ (go terminal))
+ (#\A (push (if (and (pop stack) (pop stack)) 1 0) stack)
+ (go terminal))
+ (#\O (push (if (or (pop stack) (pop stack)) 1 0) stack)
+ (go terminal))
+ (#\! (push (if (zerop (pop stack)) 1 0) stack)
+ (go terminal))
+ (#\~ (push (logand #xFF (lognot (pop stack))) stack)
+ (go terminal))
+ (#\i (when args
+ (incf (first args))
+ (when (cdr args)
+ (incf (second args))))
+ (go terminal))
+ (#\? (go state14))
+ (otherwise (error "Unknown %-control character: ~C" c)))
+ state1
+ (let ((next (peek-char nil in nil)))
+ (when (position next "0123456789# +-doXxs")
+ (go state2)))
+ (if (char= c #\+)
+ (push (+ (pop stack) (pop stack)) stack)
+ (push (- (pop stack) (pop stack)) stack))
+ (go terminal)
+ state2
+ (case c
+ (#\# (setf flags (logior flags 1)))
+ (#\+ (setf flags (logior flags 2)))
+ (#\Space (setf flags (logior flags 4)))
+ (#\- (setf flags (logior flags 8)))
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+ (go state3))
+ (t (go blah)))
+ (setf c (read-char in))
+ (go state2)
+ state3
+ (setf width (digit-char-p c))
+ state3-loop
+ (setf c (read-char in))
+ (case c
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+ (setf width (+ (* width 10) (digit-char-p c)))
+ (go state3-loop))
+ (#\. (setf c (read-char in)) (go state4)))
+ (go blah)
+ state4
+ (setf precision (digit-char-p c))
+ state4-loop
+ (setf c (read-char in))
+ (case c
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+ (setf precision (+ (* precision 10) (digit-char-p c)))
+ (go state4-loop)))
+ (go blah)
+ blah
+ (case c
+ (#\d (go state5))
+ (#\o (go state6))
+ ((#\X #\x) (go state7))
+ (#\s (go state8))
+ (otherwise (error "Unknown %-control character: ~C" c)))
+ state5
+ (let ((value (pop stack)))
+ (format out (if (logbitp 3 flags)
+ "~@v<~:[~*~;~C~]~v,'0D~>"
+ "~v<~:[~*~;~C~]~v,'0D~>")
+ width
+ (or (minusp value) (logbitp 1 flags)
+ (logbitp 2 flags))
+ (if (minusp value)
+ #\-
+ (if (logbitp 1 flags)
+ #\+
+ #\Space))
+ precision
+ (abs value)))
+ (go terminal)
+ state6
+ (format out (if (logbitp 3 flags)
+ "~@v<~@[0~*~]~v,'0O~>"
+ "~v<~@[0~*~]~v,'0O~>")
+ width (logbitp 0 flags) precision
+ (pop stack))
+ (go terminal)
+ state7
+ (format out (if (logbitp 3 flags)
+ "~@v<~:[~*~;0~C~]~v,'0X~>"
+ "~v<~:[~*~;0~C~]~v,'0X~>")
+ width (logbitp 0 flags) c precision
+ (pop stack))
+ (go terminal)
+ state8
+ (format t "~&;; Width ~D, Precision ~D, flags=#x~X: string"
+ width precision flags)
+ (go terminal)
+ state9
+ (let* ((i (digit-char-p (read-char in)))
+ (a (nth (1- i) args)))
+ (etypecase a
+ (character (push (char-code a) stack))
+ (integer (push a stack))))
+ (go terminal)
+ state10
+ (let ((var (read-char in)))
+ (cond ((char<= #\a var #\z)
+ (setf (aref dvars (- (char-code var)
+ (char-code #\a)))
+ (pop stack)))
+ ((char<= #\A var #\Z)
+ (setf (aref svars (- (char-code var)
+ (char-code #\A)))
+ (pop stack)))
+ (t (error "Illegal variable name: ~C" var))))
+ (go terminal)
+ state11
+ (let ((var (read-char in)))
+ (cond ((char<= #\a var #\z)
+ (push (aref dvars (- (char-code var)
+ (char-code #\a)))
+ stack))
+ ((char<= #\A var #\Z)
+ (push (aref svars (- (char-code var)
+ (char-code #\A)))
+ stack))
+ (t (error "Illegal variable name: ~C" var))))
+ (go terminal)
+ state12
+ (push (char-code (read-char in)) stack)
+ (unless (char= (read-char in) #\')
+ (error "Invalid character constant"))
+ (go terminal)
+ state13
+ (setq number 0)
+ state13-loop
+ (setq c (read-char in))
+ (let ((n (digit-char-p c)))
+ (cond (n (setq number (+ (* 10 number) n))
+ (go state13-loop))
+ ((char= c #\})
+ (push number stack)
+ (go terminal))))
+ (error "Invalid integer constant")
+ state14
+ (error "Conditional expression parser not yet written.")
+ terminal
+ #| that's all, folks |#))
+ (t (princ c out)))))))
+
+(defun tputs (string &rest args)
+ (when string
+ (princ (apply #'tparm string args) *terminal-io*)
+ t))
+
+(defun set-terminal (&optional name)
+ (setf *terminfo* (load-terminfo (or name
+ #+CMU
+ (cdr (assoc "TERM" ext:*environment-list*
+ :test #'string=))
+ #+Allegro
+ (sys:getenv "TERM")
+ #+SBCL
+ (sb-ext:posix-getenv "TERM")
+ #| if all else fails |#
+ "dumb"))))
+
+(if (null *terminfo*)
+ (set-terminal))
+
+(provide :terminfo)
Index: src/Makefile
diff -u src/Makefile:1.15 src/Makefile:1.16
--- src/Makefile:1.15 Mon Sep 29 14:06:13 2003
+++ src/Makefile Mon Oct 20 03:49:24 2003
@@ -76,3 +76,17 @@
public_html:
$(RSYNC_HTML) && $(HTML_PERMS)
+
+TI_VERSION=1.0
+TI=terminfo_$(TI_VERSION)
+TI_LINK=terminfo_latest.tar.gz
+
+terminfo:
+ mkdir -p $(TI)
+ cp terminfo.lisp terminfo.asd $(TI)/
+ tar -czvf $(TI).tar.gz $(TI)
+ gpg -b -a $(TI).tar.gz
+ rm -rf $(TI)
+ ln -s $(TI).tar.gz.asc $(TI_LINK).asc
+ ln -s $(TI).tar.gz $(TI_LINK)
+ mv $(TI).tar.gz $(TI).tar.gz.asc $(TI_LINK) $(TI_LINK).asc $(HTML)/files/
More information about the linedit-cvs
mailing list