├── doc ├── ps │ ├── hemlock-cim.ps.gz │ └── hemlock-user.ps.gz ├── scribe-converter │ ├── NOTES │ └── README └── misc │ ├── notes.txt │ ├── hemlock.upd │ ├── compilation.order │ └── perq-hemlock.log ├── .gitignore ├── hemlock.qt.sh ├── ttyhemlock.sh ├── src ├── qt-package.lisp ├── port.lisp ├── tty-stuff.lisp ├── grep.lisp ├── wire-package.lisp ├── pascal.lisp ├── xcoms.lisp ├── dylan.lisp ├── overwrite.lisp ├── icom.lisp ├── lispdep.lisp ├── decls.lisp ├── repl.lisp ├── request.lisp ├── termcap.lisp ├── spell-rt.lisp ├── patch.lisp ├── debug.lisp ├── typeout.lisp ├── files.lisp ├── bitmap-input.lisp ├── pop-up-stream.lisp ├── font.lisp ├── apropos.lisp ├── bit-stuff.lisp ├── bitmap-pop-up-stream.lisp ├── line.lisp ├── slave-list.lisp ├── bitmap-rompsite.lisp ├── charmacs.lisp ├── dabbrev.lisp ├── register.lisp └── xref.lisp ├── unused ├── elisp │ ├── compile.lisp │ ├── loadup.lisp │ ├── cmucl-hemlock-glue.lisp │ ├── packages.lisp │ ├── README │ ├── hemlock-shims.lisp │ ├── codewalker.lisp │ └── read-table.lisp ├── hemlock11.mask ├── spell │ ├── package.lisp │ ├── hashing.lisp │ ├── spell.asd │ ├── classes.lisp │ ├── README │ ├── flags.lisp │ ├── constants.lisp │ └── io.lisp ├── hacks.lisp ├── gosmacs.lisp ├── struct-ed.lisp ├── hi-integrity.lisp ├── tty-stream.lisp ├── bit-stream.lisp ├── hemlock.system └── ed-integrity.lisp ├── resources ├── mh-scan ├── hemlock11.cursor └── XKeysymDB ├── c ├── Makefile └── setpty.c ├── INSTALL ├── hemlock.qt.asd ├── hemlock.clx.asd ├── hemlock.tty.asd └── dist.sh /doc/ps/hemlock-cim.ps.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bluelisp/hemlock/HEAD/doc/ps/hemlock-cim.ps.gz -------------------------------------------------------------------------------- /doc/ps/hemlock-user.ps.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bluelisp/hemlock/HEAD/doc/ps/hemlock-user.ps.gz -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.fas 3 | *.lib 4 | *.lx64fsl 5 | *~ 6 | c/setpty 7 | c/setpty.o 8 | hemlock.core 9 | -------------------------------------------------------------------------------- /hemlock.qt.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | clbuild lisp <%<{replied}A%| %> \ 2 | %02(putnumf(mday{date}))-%(putstr(month{date}))%<{date} %|*%>\ 3 | %5(size) \ 4 | %<(mymbox{from})To:%14(putstrf(friendly{to}))%|%17(putstrf(friendly{from}))%> \ 5 | %{subject}%<{body} <<%{body}%> 6 | -------------------------------------------------------------------------------- /unused/hemlock11.mask: -------------------------------------------------------------------------------- 1 | #define noname_width 16 2 | #define noname_height 16 3 | static char noname_bits[] = { 4 | 0x0c,0x00,0x1c,0x00,0x3c,0x00,0x7c,0x00,0xfc,0x00,0xfc,0x01,0xfc,0x03,0xfc, 5 | 0x07,0xfc,0x0f,0xfc,0x0f,0xfc,0x01,0xdc,0x03,0xcc,0x03,0x80,0x07,0x80,0x07, 6 | 0x00,0x03}; 7 | -------------------------------------------------------------------------------- /c/Makefile: -------------------------------------------------------------------------------- 1 | CC:=cc 2 | CFLAGS=-std=c89 -pedantic -g -Wall -Wno-parentheses 3 | LDFLAGS:= 4 | 5 | all: setpty 6 | 7 | .PHONY: clean 8 | clean: 9 | rm -f setpty.o setpty 10 | 11 | %.o: %.cpp 12 | $(CC) -c -o $@ $< -I. $(CFLAGS) 13 | 14 | setpty: setpty.o 15 | $(CC) -o $@ $^ $(LDFLAGS) 16 | cp $@ ../ 17 | -------------------------------------------------------------------------------- /resources/hemlock11.cursor: -------------------------------------------------------------------------------- 1 | #define noname_width 16 2 | #define noname_height 16 3 | #define noname_x_hot 3 4 | #define noname_y_hot 1 5 | static char noname_bits[] = { 6 | 0x00,0x00,0x08,0x00,0x18,0x00,0x38,0x00,0x78,0x00,0xf8,0x00,0xf8,0x01,0xf8, 7 | 0x03,0xf8,0x07,0xf8,0x00,0xd8,0x00,0x88,0x01,0x80,0x01,0x00,0x03,0x00,0x03, 8 | 0x00,0x00}; 9 | -------------------------------------------------------------------------------- /unused/elisp/loadup.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | ;; Files to load 4 | (load "packages") 5 | (load "read-table") 6 | (load "base") 7 | (load "codewalker") 8 | (load "internals") 9 | (load "hemlock-shims") 10 | 11 | ;; Functions to call 12 | (let ((*package* (find-package :elisp))) 13 | (elisp-internals:generate-cl-package)) 14 | -------------------------------------------------------------------------------- /src/port.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :hemlock.wire) 4 | 5 | (defun unix-gethostid () 6 | #.(or 7 | #+CMU '(unix:unix-gethostid) 8 | 398792)) 9 | 10 | (defun unix-getpid () 11 | (conium:getpid)) 12 | 13 | ;; fixme: remove this? 14 | (push (cons '*print-readably* nil) 15 | bt:*default-special-bindings*) 16 | -------------------------------------------------------------------------------- /unused/spell/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (defpackage "SPELL" 4 | (:use "COMMON-LISP") 5 | (:export #:spell-try-word #:spell-root-word #:spell-collect-close-words 6 | #:correct-spelling 7 | #:+max-entry-length+ 8 | #:spell-read-dictionary #:spell-add-entry #:spell-root-flags 9 | #:spell-remove-entry)) -------------------------------------------------------------------------------- /doc/scribe-converter/NOTES: -------------------------------------------------------------------------------- 1 | Scribe Syntax 2 | 3 | The Syntax of Scribe is actually very nice. A command is always 4 | introduced by #\@ followed by the command name and arguments delimited 5 | by delimiters (sic). 6 | 7 | The following delimiter pairs are supported: 8 | 9 | { } [ ] < > ( ) " " ' ' 10 | 11 | 12 | 13 | $Id: NOTES,v 1.1 2004-07-09 13:37:13 gbaumann Exp $ 14 | -------------------------------------------------------------------------------- /doc/scribe-converter/README: -------------------------------------------------------------------------------- 1 | This directory should eventually contain a scribe to HTML converter 2 | using the same backend formatter as i used for the annotatable CLIM 3 | manual. 4 | 5 | Since very rare information about Scribe is available, we'll work by 6 | infering the neccessary information from the Scribe files we have at 7 | hand, see file NOTES for details. 8 | 9 | $Id: README,v 1.1 2004-07-09 13:37:13 gbaumann Exp $ 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /src/tty-stuff.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :hi) 4 | 5 | ;;; Terminal hunks. 6 | ;;; 7 | (defclass tty-hunk (device-hunk) 8 | ((text-position :initarg :text-position 9 | :accessor tty-hunk-text-position) 10 | (text-height :initarg :text-height 11 | :accessor tty-hunk-text-height))) 12 | 13 | (defun make-tty-hunk (&rest args 14 | &key position height text-position text-height device) 15 | (declare (ignore position height text-position text-height device)) 16 | (apply #'make-instance 'tty-hunk args)) 17 | -------------------------------------------------------------------------------- /unused/spell/hashing.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package "SPELL") 4 | 5 | ;;; FIXME: the original code included the below comment; obviously, it 6 | ;;; utilized implementation-specific primitives to speed up hashing. is 7 | ;;; this reasonable to do? 8 | ;;; 9 | ;;; STRING-HASH employs the instruction SXHASH-SIMPLE-SUBSTRING which takes 10 | ;;; an end argument, so we do not have to use SXHASH. SXHASH would mean 11 | ;;; doing a SUBSEQ of entry. 12 | (declaim (inline string-hash)) 13 | (defun string-hash (string length) 14 | (if (= length (length string)) 15 | (sxhash string) 16 | (sxhash (subseq string 0 length)))) 17 | -------------------------------------------------------------------------------- /unused/elisp/cmucl-hemlock-glue.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; File to fix Irritating Impedance Mismatch between 4 | ;;; CMU CL Hemlock and PortableHemlock. 5 | 6 | #+cmu 7 | (unless (find-package :hemlock-ext) 8 | #-hemlock 9 | (progn 10 | (load "/usr/share/common-lisp/systems/cmucl-hemlock.system") 11 | (mk:oos :cmucl-hemlock :load)) 12 | 13 | ;; OK, here comes the nasty. CMUCLHemlock stuffs things in the "EXT" 14 | ;; package (system-dependent stuff, basically). We expect things to be 15 | ;; orderly and live in a Hemlock package. Thus: 16 | (common-lisp::enter-new-nicknames (find-package "EXTENSIONS") '("HEMLOCK-EXT"))) 17 | 18 | -------------------------------------------------------------------------------- /unused/spell/spell.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | (defpackage :spell-system (:use :cl :asdf)) 3 | (in-package :spell-system) 4 | 5 | (defsystem spell 6 | :version "0.4" 7 | :components ((:file "package") 8 | (:file "constants" :depends-on ("package")) 9 | (:file "hashing" :depends-on ("package")) 10 | (:file "flags") 11 | (:file "classes" :depends-on ("package")) 12 | (:file "build" :depends-on ("constants" "hashing" 13 | "flags" "classes")) 14 | ;; kind of a fake dependency 15 | (:file "io" :depends-on ("build")) 16 | (:file "correlate" :depends-on ("build")))) -------------------------------------------------------------------------------- /unused/hacks.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package "HI") 4 | 5 | (defun %sp-byte-blt (src start dest dstart end) 6 | (%primitive byte-blt src start dest dstart end)) 7 | 8 | (defun lisp::sap-to-fixnum (x) (sap-int x)) 9 | (defun lisp::fixnum-to-sap (x) (int-sap x)) 10 | (defun lisp::%sp-make-fixnum (x) (%primitive make-fixnum x)) 11 | (defun lisp::fast-char-upcase (x) (char-upcase x)) 12 | 13 | ;;; prepare-window-for-redisplay -- Internal 14 | ;;; 15 | ;;; Called by make-window to do whatever redisplay wants to set up 16 | ;;; a new window. 17 | ;;; 18 | (defun prepare-window-for-redisplay (window) 19 | (setf (window-old-lines window) 0)) 20 | 21 | (defparameter hunk-width-limit 256) 22 | 23 | (defun reverse-video-hook-fun (&rest foo) 24 | (declare (ignore foo))) 25 | -------------------------------------------------------------------------------- /doc/misc/notes.txt: -------------------------------------------------------------------------------- 1 | (defcommand "Find File From Sources" (p) 2 | "" "" 3 | (declare (ignore p)) 4 | (let ((point (current-point))) 5 | (with-mark ((start point) 6 | (end point)) 7 | (find-file-command 8 | nil 9 | (merge-pathnames "src:" 10 | (region-to-string (region (line-start start) 11 | (line-end end)))))))) 12 | 13 | * abbrev.lisp 14 | * doccoms.lisp 15 | * echo.lisp 16 | * echocoms.lisp 17 | * filecoms.lisp 18 | * lisp-lib.lisp ;Blew away help command, should do describe mode. 19 | * lispbuf.lisp 20 | * lispeval.lisp ;Maybe write MESSAGE-EVAL_FORM-RESULTS. 21 | * macros.lisp <<< Already changed in WORK: 22 | * mh.lisp <<< Ask Bill about INC in "Incorporate New Mail". 23 | * morecoms.lisp 24 | * register.lisp 25 | * scribe.lisp 26 | * searchcoms.lisp 27 | * spellcoms.lisp 28 | -------------------------------------------------------------------------------- /unused/spell/classes.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :spell) 4 | 5 | (defclass dictionary () 6 | ((string-table :accessor string-table :initarg :string-table) 7 | (descriptors :accessor descriptors :initarg :descriptors) 8 | ;; maps from hashes of strings to their corresponding descriptors 9 | (descriptor-table :accessor descriptor-table 10 | :initarg :descriptor-table) 11 | (free-descriptors :accessor free-descriptors 12 | :initarg :free-descriptors 13 | :initform 0) 14 | (free-string-table-bytes :accessor free-string-table-bytes 15 | :initarg :free-string-table-bytes 16 | :initform 0))) 17 | 18 | (defstruct (descriptor 19 | (:conc-name desc-)) 20 | hash-code 21 | length 22 | string-index 23 | flags) 24 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | About Hemlock 2 | 3 | Hemlock is an Emacs-style editor written in Common Lisp. 4 | 5 | Originally written as a part of CMUCL, work started in 2002 to make it 6 | portable to other Common Lisp implementations. 7 | 8 | 9 | Backends 10 | 11 | This version of Hemlock has three backends, of which you need at least 12 | one: 13 | 14 | * The TTY backend doesn't need much, except for a terminal 15 | and an installed terminfo database. 16 | 17 | * The X11 backend needs CLX and an X server. 18 | 19 | * The experimental Qt backends needs CommonQt. 20 | 21 | 22 | 23 | Building and invocation of a binary 24 | 25 | ./build.sh 26 | ./hemlock --help 27 | 28 | 29 | Building and invocation from the REPL 30 | 31 | (push #p"/path/to/hemlock/" asdf:*central-registry*) 32 | (asdf:operate 'asdf:load-op :hemlock.tty) 33 | (asdf:operate 'asdf:load-op :hemlock.clx) 34 | (asdf:operate 'asdf:load-op :hemlock.qt) 35 | 36 | (hemlock:hemlock) 37 | or just 38 | (ed) ;SBCL and CCL only 39 | -------------------------------------------------------------------------------- /hemlock.qt.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (defparameter *hemlock-base-directory* 4 | (make-pathname :name nil :type nil :version nil 5 | :defaults (parse-namestring *load-truename*))) 6 | 7 | (asdf:defsystem :hemlock.qt 8 | :pathname #.(make-pathname 9 | :directory 10 | (pathname-directory *hemlock-base-directory*) 11 | :defaults *hemlock-base-directory*) 12 | :depends-on (:hemlock.base :qt :qt-repl) 13 | :components 14 | ((:module qt-1 15 | :pathname #.(merge-pathnames 16 | (make-pathname 17 | :directory '(:relative "src")) 18 | *hemlock-base-directory*) 19 | :serial t 20 | :components 21 | ((:file "qt-package") 22 | (:file "qt") 23 | (:file "browser") 24 | (:file "qtconnections") 25 | (:file "sugiyama") 26 | (:file "graphics"))))) 27 | -------------------------------------------------------------------------------- /src/grep.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :hemlock) 4 | 5 | (defmode "Grep" :major-p t 6 | :documentation 7 | "Grep results") 8 | 9 | (defcommand "Grep" 10 | (p &optional (command (hi::prompt-for-string 11 | :prompt "Run grep (like this): " 12 | :default "grep -nH -e ")) 13 | (directory (default-directory))) 14 | "" "" 15 | #+scl (setf directory (ext:unix-namestring directory nil)) 16 | (setf (buffer-major-mode (shell-command-command p command directory)) 17 | "Grep")) 18 | 19 | (defcommand "Grep Goto" (p) 20 | "" "" 21 | (declare (ignore p)) 22 | (cl-ppcre:register-groups-bind (file line) 23 | ("^\([^:]+\):\([0-9]+\):" (line-string (mark-line (current-point)))) 24 | (when file 25 | (change-to-buffer (find-file-buffer (merge-pathnames file (default-directory)))) 26 | (let ((point (current-point))) 27 | (push-buffer-mark (copy-mark point)) 28 | (buffer-start point) 29 | (when line 30 | (line-offset point (1- (parse-integer line)))))))) 31 | 32 | (bind-key "Grep Goto" #k"return" :mode "Grep") 33 | -------------------------------------------------------------------------------- /hemlock.clx.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (defparameter *hemlock-base-directory* 4 | (make-pathname :name nil :type nil :version nil 5 | :defaults (parse-namestring *load-truename*))) 6 | 7 | (asdf:defsystem :hemlock.clx 8 | :pathname #.(make-pathname 9 | :directory 10 | (pathname-directory *hemlock-base-directory*) 11 | :defaults *hemlock-base-directory*) 12 | :depends-on (:hemlock.base :clx) 13 | :components 14 | ((:module clx-1 15 | :pathname #.(merge-pathnames 16 | (make-pathname 17 | :directory '(:relative "src")) 18 | *hemlock-base-directory*) 19 | :components 20 | ((:file "bit-stuff") 21 | (:file "hunk-draw" :depends-on ("bit-stuff")) 22 | (:file "bitmap-rompsite") 23 | (:file "ioconnections") 24 | (:file "bitmap-input") 25 | (:file "bit-display" :depends-on ("hunk-draw")) 26 | (:file "bit-screen") 27 | (:file "bitmap-ext"))))) 28 | -------------------------------------------------------------------------------- /unused/spell/README: -------------------------------------------------------------------------------- 1 | SPELL was originally part of Hemlock, CMUCL's Common Lisp text editor. 2 | This version has been mostly rewritten in portable ANSI CL. The only 3 | file that remains to be converted is spell-aug.lisp. Besides ripping 4 | out implementation-specific code, the biggest change is that the spelling 5 | dictionary is no longer a global variable. Instead, it has been 6 | converted to be a class; multiple dictionaries may thus coexist at any 7 | one time. Most functions have therefore been changed to take an extra 8 | DICTIONARY parameter. 9 | 10 | An ASDF system definition is contained in spell.asd. 11 | 12 | Semi-extensive testing has been done. However, a test suite would be 13 | a good thing to write. 14 | 15 | To get started, compile and load the system, then enter 16 | 17 | (SPELL::BUILD-DICTIONARY #p"/path/to/spell-dictionary.text" "outfile") 18 | (SETF MY-DICTIONARY *) 19 | (CORRECT-SPELLING MY-DICTIONARY "debugg") 20 | 21 | spellcoms.lisp is a file containing Hemlock commands and functions to 22 | integrate the SPELL package into Hemlock. It needs to be rewritten 23 | to work with the new code, but is an example of what can be done with 24 | the provided interfaces. 25 | 26 | Please email any comments, questions, or bug fixes to froydnj@cs.rice.edu. 27 | -------------------------------------------------------------------------------- /hemlock.tty.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (defparameter *hemlock-base-directory* 4 | (make-pathname :name nil :type nil :version nil 5 | :defaults (parse-namestring *load-truename*))) 6 | 7 | (asdf:defsystem :hemlock.tty 8 | :pathname #.(make-pathname 9 | :directory 10 | (pathname-directory *hemlock-base-directory*) 11 | :defaults *hemlock-base-directory*) 12 | :depends-on (:hemlock.base) 13 | :components 14 | ((:module tty-1 15 | :pathname #.(merge-pathnames 16 | (make-pathname 17 | :directory '(:relative "src")) 18 | *hemlock-base-directory*) 19 | :components 20 | ((:file "ioconnections") 21 | (:file "terminfo") 22 | (:file "termcap" :depends-on ("terminfo")) 23 | (:file "tty-disp-rt") 24 | (:file "tty-display" :depends-on ("terminfo" "tty-disp-rt")) 25 | (:file "tty-screen" :depends-on ("terminfo" "tty-disp-rt")) 26 | (:file "tty-stuff") 27 | (:file "tty-input" :depends-on ("terminfo")) 28 | (:file "linedit" :depends-on ("tty-display")))))) 29 | -------------------------------------------------------------------------------- /src/wire-package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (defpackage :hemlock.wire 4 | (:use :common-lisp) 5 | (:nicknames :wire) 6 | (:export 7 | ;; wire.lisp 8 | #:remote-object-p 9 | #:remote-object 10 | #:remote-object-local-p 11 | #:remote-object-eq 12 | #:remote-object-value 13 | #:make-remote-object 14 | #:forget-remote-translation 15 | #:make-wire 16 | #:wire-p 17 | #:wire-fd 18 | #:wire-listen 19 | #:wire-get-byte 20 | #:wire-get-number 21 | #:wire-get-string 22 | #:wire-get-object 23 | #:wire-force-output 24 | #:wire-output-byte 25 | #:wire-output-number 26 | #:wire-output-string 27 | #:wire-output-object 28 | #:wire-output-funcall 29 | #:wire-error 30 | #:wire-eof 31 | #:wire-io-error 32 | #:*current-wire* 33 | #:wire-get-bignum 34 | #:wire-output-bignum 35 | ;; remote.lisp 36 | #:remote 37 | #:remote-value 38 | #:remote-value-bind 39 | #:create-request-server 40 | #:destroy-request-server 41 | 42 | #:device 43 | #:stream-device 44 | #:make-stream-device 45 | #:device-wire 46 | #:device-append-to-input-buffer 47 | #:device-read 48 | #:device-listen 49 | #:device-write 50 | #:device-close 51 | #:device-serve-requests 52 | 53 | #:dispatch-events 54 | #:dispatch-events-no-hang)) 55 | -------------------------------------------------------------------------------- /unused/gosmacs.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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: /home/david/phemlock/cvsroot/phemlock/unused/gosmacs.lisp,v 1.1 2004-07-09 13:39:12 gbaumann Exp $") 9 | ;;; 10 | ;;; ********************************************************************** 11 | ;;; 12 | ;;; Stuff in this file provides some degree of upward compatibility 13 | ;;; for incurable Gosling Emacs users. 14 | ;;; 15 | (in-package "HEMLOCK") 16 | 17 | (defcommand "Gosmacs Permute Characters" (p) 18 | "Transpose the two characters before the point." 19 | "Transpose the two characters before the point." 20 | (declare (ignore p)) 21 | (with-mark ((m (current-point) :left-inserting)) 22 | (unless (and (mark-before m) (previous-character m)) 23 | (editor-error "NIB You have addressed a character not in the buffer?")) 24 | (rotatef (previous-character m) (next-character m)))) 25 | 26 | (bind-key "Gosmacs Permute Characters" #k"control-t") 27 | (bind-key "Kill Previous Word" #k"meta-h") 28 | (bind-key "Replace String" #k"meta-r") 29 | (bind-key "Query Replace" #k"meta-q") 30 | (bind-key "Fill Paragraph" #k"meta-j") 31 | (bind-key "Visit File" #k"control-x control-r") 32 | (bind-key "Find File" #k"control-x control-v") 33 | (bind-key "Insert File" #k"control-x control-i") 34 | -------------------------------------------------------------------------------- /unused/elisp/packages.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (defpackage "ELISP" 4 | (:shadow "=" "DEFUN" "LET" "IF" "SETQ" "ASSOC" "COMMANDP" "AREF") 5 | (:use "COMMON-LISP" "HEMLOCK-INTERNALS") 6 | (:export 7 | "%" 8 | "=" 9 | "ABORT-RECURSIVE-EDIT" 10 | "AREF" 11 | "ASET" 12 | "ASSQ" 13 | "ASSOC" 14 | "AUTOLOAD" 15 | "BOBP" 16 | "BODY" 17 | "BOLP" 18 | "BOOL-VECTOR-P" 19 | "BUFFER-LOCAL-P" 20 | "CAR-LESS-THAN-CAR" 21 | "CAR-SAFE" 22 | "CDR-SAFE" 23 | "COMMANDP" 24 | "DEFMACRO" 25 | "DEFUN" 26 | "DEFVAR" 27 | "FEATURES" 28 | "FILENAME" 29 | "GET-BUFFER" 30 | "GET-BUFFER-CREATE" 31 | "GET-DEFAULT" 32 | "GLOBAL-SET-KEY" 33 | "IF" 34 | "INTERACTIVE" 35 | "KEY" 36 | "KEYMAP" 37 | "LET" 38 | "LEXICAL-LET" 39 | "LOAD-FILE" 40 | "LOAD-LIBRARY" 41 | "LOAD-PATH" 42 | "LOCAL-SET-KEY" 43 | "MAKE-BOOL-VECTOR" 44 | "MAKE-KEYMAP" 45 | "MAKE-VARIABLE-BUFFER-LOCAL" 46 | "MAKE-SPARSE-KEYMAP" 47 | "NOERROR" 48 | "SET-DEFAULT" 49 | "SETQ" 50 | "USE-LOCAL-MAP" 51 | "WHILE" 52 | ) 53 | ) 54 | (defpackage "ELISP-INTERNALS" 55 | (:shadow "READ-STRING") 56 | (:use "COMMON-LISP") 57 | (:export 58 | "FIND-LAMBDA-LIST-VARIABLES" 59 | "GENERATE-CL-PACKAGE" 60 | "REQUIRE-LOAD" 61 | "GET-USER-HOMEDIR" 62 | "INTERACTIVE-GLUE" 63 | "*ELISP-READTABLE*" 64 | "*EMACS-VERSION*" 65 | "*CL-ELISP-RELEASE*" 66 | ) 67 | ) 68 | (defpackage "ELISP-USER" 69 | (:use "ELISP" "ELISP-INTERNALS") 70 | ) 71 | -------------------------------------------------------------------------------- /src/pascal.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; Just barely enough to be a Pascal/C mode. Maybe more some day. 11 | ;;; 12 | (in-package :hemlock) 13 | 14 | (defmode "Pascal" :major-p t) 15 | (defcommand "Pascal Mode" (p) 16 | "Put the current buffer into \"Pascal\" mode." 17 | "Put the current buffer into \"Pascal\" mode." 18 | (declare (ignore p)) 19 | (setf (buffer-major-mode (current-buffer)) "Pascal")) 20 | 21 | (defhvar "Indent Function" 22 | "Indentation function which is invoked by \"Indent\" command. 23 | It must take one argument that is the prefix argument." 24 | :value #'generic-indent 25 | :mode "Pascal") 26 | 27 | (defhvar "Auto Fill Space Indent" 28 | "When non-nil, uses \"Indent New Comment Line\" to break lines instead of 29 | \"New Line\"." 30 | :mode "Pascal" :value t) 31 | 32 | (defhvar "Comment Start" 33 | "String that indicates the start of a comment." 34 | :mode "Pascal" :value "(*") 35 | 36 | (defhvar "Comment End" 37 | "String that ends comments. Nil indicates #\newline termination." 38 | :mode "Pascal" :value " *)") 39 | 40 | (defhvar "Comment Begin" 41 | "String that is inserted to begin a comment." 42 | :mode "Pascal" :value "(* ") 43 | 44 | (shadow-attribute :scribe-syntax #\< nil "Pascal") 45 | -------------------------------------------------------------------------------- /src/xcoms.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; This file contains commands and support specifically for X related features. 11 | ;;; 12 | ;;; Written by Bill Chiles. 13 | ;;; 14 | 15 | (in-package :hemlock) 16 | 17 | 18 | (defcommand "Region to Cut Buffer" (p) 19 | "Place the current region into the X cut buffer." 20 | "Place the current region into the X cut buffer." 21 | (declare (ignore p)) 22 | (store-cut-string (hi::bitmap-device-display 23 | (hi::device-hunk-device (hi::window-hunk (current-window)))) 24 | (region-to-string (current-region)))) 25 | 26 | (defcommand "Insert Cut Buffer" (p) 27 | "Insert the X cut buffer at current point." 28 | "Insert the X cut buffer at current point. Returns nil when it is empty." 29 | (declare (ignore p)) 30 | (let ((str (fetch-cut-string (hi::bitmap-device-display 31 | (hi::device-hunk-device 32 | (hi::window-hunk (current-window))))))) 33 | (if str 34 | (let ((point (current-point))) 35 | (push-buffer-mark (copy-mark point)) 36 | (insert-string (current-point) str)) 37 | (editor-error "X cut buffer empty."))) 38 | (setf (last-command-type) :ephemerally-active)) 39 | -------------------------------------------------------------------------------- /c/setpty.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | int set_noecho(int fd) 11 | { 12 | /* borrowed from SBCL, which borrowed from detachtty's detachtty.c, 13 | * in turn borrowed from APUE. example code found at 14 | * http://www.yendor.com/programming/unix/apue/pty/main.c 15 | */ 16 | struct termios stermios; 17 | 18 | if (tcgetattr(fd, &stermios) < 0) return 0; 19 | 20 | stermios.c_lflag &= ~( ECHO | /* ECHOE | ECHOK | */ ECHONL); 21 | stermios.c_oflag |= (ONLCR); 22 | /* in contrast to the code in SBCL, we don't want CR except where 23 | * user code asks for the line to be cleared: */ 24 | stermios.c_oflag &= ~(ONLCR); 25 | stermios.c_iflag &= ~(BRKINT); 26 | stermios.c_iflag |= (ICANON|ICRNL); 27 | 28 | stermios.c_cc[VERASE]=0177; 29 | if (tcsetattr(fd, TCSANOW, &stermios) < 0) return 0; 30 | return 1; 31 | } 32 | 33 | int 34 | main(int argc, char **argv) 35 | { 36 | char *ptyname; 37 | int fd; 38 | 39 | if (argc < 3) return 1; 40 | 41 | /* grab ourselves a new process group */ 42 | setsid(); 43 | 44 | /* get rid of the old tty, if any */ 45 | fd = open("/dev/tty", O_RDWR, 0); 46 | if (fd >= 0) { 47 | ioctl(fd, TIOCNOTTY, 0); 48 | close(fd); 49 | } 50 | 51 | /* here comes the new one */ 52 | ptyname = argv[1]; 53 | close(0); 54 | if (open(ptyname, O_RDWR) != 0) perror("open"); 55 | dup2(0, 1); 56 | dup2(0, 2); 57 | set_noecho(0); 58 | 59 | execvp(argv[2], argv + 2); 60 | perror("exec"); 61 | } 62 | -------------------------------------------------------------------------------- /unused/spell/flags.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package "SPELL") 4 | 5 | ;;; FIXME: show where these things are documented 6 | (defconstant +V-mask+ (ash 1 13)) 7 | (defconstant +N-mask+ (ash 1 12)) 8 | (defconstant +X-mask+ (ash 1 11)) 9 | (defconstant +H-mask+ (ash 1 10)) 10 | (defconstant +Y-mask+ (ash 1 9)) 11 | (defconstant +G-mask+ (ash 1 8)) 12 | (defconstant +J-mask+ (ash 1 7)) 13 | (defconstant +D-mask+ (ash 1 6)) 14 | (defconstant +T-mask+ (ash 1 5)) 15 | (defconstant +R-mask+ (ash 1 4)) 16 | (defconstant +Z-mask+ (ash 1 3)) 17 | (defconstant +S-mask+ (ash 1 2)) 18 | (defconstant +P-mask+ (ash 1 1)) 19 | (defconstant +M-mask+ 1) 20 | 21 | (defconstant flag-names-to-masks 22 | `((#\V . ,+V-mask+) (#\N . ,+N-mask+) (#\X . ,+X-mask+) 23 | (#\H . ,+H-mask+) (#\Y . ,+Y-mask+) (#\G . ,+G-mask+) 24 | (#\J . ,+J-mask+) (#\D . ,+D-mask+) (#\T . ,+T-mask+) 25 | (#\R . ,+R-mask+) (#\Z . ,+Z-mask+) (#\S . ,+S-mask+) 26 | (#\P . ,+P-mask+) (#\M . ,+M-mask+))) 27 | 28 | (defvar *flag-masks* 29 | (make-array 128 :element-type '(unsigned-byte 16) :initial-element 0) 30 | "This holds the masks for character flags, which is used when reading 31 | a text file of dictionary words. Illegal character flags hold zero.") 32 | 33 | (declaim (inline flag-mask)) 34 | (defun flag-mask (char) 35 | (aref *flag-masks* (char-code char))) 36 | (defun (setf flag-mask) (value char) 37 | (setf (aref *flag-masks* (char-code char)) value)) 38 | 39 | (dolist (e flag-names-to-masks) 40 | (let ((char (car e)) 41 | (mask (cdr e))) 42 | (setf (flag-mask char) mask) 43 | (setf (flag-mask (char-downcase char)) mask))) -------------------------------------------------------------------------------- /dist.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh -e 2 | set -x 3 | 4 | # use this script to set up a binary distribution of hemlock. 5 | # 6 | # Since the binary is not relocatable at the moment, you need to 7 | # build it in the place where it would be extracted on the user's system. 8 | # 9 | # 1. Make a directory /opt/hemlock 10 | # 11 | # 2. Check out clbuild to /opt/hemlock/clbuild 12 | # 2a. (Optionally) Install Qt libraries into /opt/hemlock/lib 13 | # 14 | # 3. Use clbuild to download hemlock 15 | # 16 | # 4. Use clbuild to download SBCL, patch it using sbcl.diff and build it 17 | # 18 | # 5. Run this script 19 | # 20 | # 6. Find tarballs in /opt/hemlock 21 | # 22 | # - Only the -base- tarballs is required for users. 23 | # - The optional -qt- tarball extracts on top of the -base- tarball 24 | # and enables use of the qt backend. 25 | # - The optional -src- tarball enabled use of M-. 26 | # 27 | 28 | base=/opt/hemlock 29 | ver=$(date '+%Y-%m-%d')-$(cd $base/clbuild/source/hemlock && git show-ref --hash=8 HEAD) 30 | export PATH=$base/clbuild:$PATH 31 | 32 | cd $base/clbuild/source/hemlock 33 | ./build.sh tty qt clx 34 | cp hemlock $base/ 35 | 36 | cd $base 37 | 38 | tar cjf hemlock-bin-base-$ver.tar.bz2 \ 39 | --absolute-names \ 40 | --exclude '*/sbcl.core' \ 41 | $base/hemlock \ 42 | $base/clbuild/source/iolib/src/syscalls/libiolib-syscalls.so \ 43 | $base/clbuild/source/osicat/posix/libosicat.so \ 44 | $base/clbuild/target/lib/sbcl \ 45 | $base/clbuild/source/hemlock/resources/hemlock11.cursor 46 | 47 | tar cjf hemlock-bin-qt-$ver.tar.bz2 \ 48 | --absolute-names \ 49 | $base/background.svg \ 50 | $base/clbuild/source/commonqt/libcommonqt.so* \ 51 | $base/lib 52 | 53 | tar cjf hemlock-src-$ver.tar.bz2 \ 54 | --absolute-names \ 55 | --exclude '*/sbcl.core' \ 56 | --exclude '*/source/hemlock/hemlock' \ 57 | --exclude '*/source/sbcl/obj/*' \ 58 | --exclude '*/source/sbcl/output/*' \ 59 | --exclude '*.fasl' \ 60 | --exclude '*/clbuild/target/*' \ 61 | $base/clbuild 62 | -------------------------------------------------------------------------------- /doc/misc/hemlock.upd: -------------------------------------------------------------------------------- 1 | struct.lisp 2 | struct-ed.lisp 3 | rompsite.lisp 4 | charmacs.lisp 5 | key-event.lisp 6 | keysym-defs.lisp 7 | input.lisp 8 | macros.lisp 9 | line.lisp 10 | ring.lisp 11 | table.lisp 12 | htext1.lisp 13 | htext2.lisp 14 | htext3.lisp 15 | htext4.lisp 16 | search1.lisp 17 | search2.lisp 18 | linimage.lisp 19 | cursor.lisp 20 | syntax.lisp 21 | winimage.lisp 22 | hunk-draw.lisp 23 | @!bit-stream.lisp 24 | termcap.lisp 25 | display.lisp 26 | bit-display.lisp 27 | tty-disp-rt.lisp 28 | tty-display.lisp 29 | @!tty-stream.lisp 30 | pop-up-stream.lisp 31 | screen.lisp 32 | bit-screen.lisp 33 | tty-screen.lisp 34 | window.lisp 35 | font.lisp 36 | interp.lisp 37 | vars.lisp 38 | buffer.lisp 39 | files.lisp 40 | streams.lisp 41 | echo.lisp 42 | main.lisp 43 | echocoms.lisp 44 | defsyn.lisp 45 | command.lisp 46 | morecoms.lisp 47 | undo.lisp 48 | killcoms.lisp 49 | searchcoms.lisp 50 | filecoms.lisp 51 | indent.lisp 52 | lispmode.lisp 53 | comments.lisp 54 | fill.lisp 55 | text.lisp 56 | doccoms.lisp 57 | srccom.lisp 58 | group.lisp 59 | spell-rt.lisp 60 | spell-corr.lisp 61 | spell-aug.lisp 62 | spell-build.lisp 63 | spellcoms.lisp 64 | abbrev.lisp 65 | overwrite.lisp 66 | gosmacs.lisp 67 | ts-buf.lisp 68 | ts-stream.lisp 69 | eval-server.lisp 70 | lispeval.lisp 71 | lispbuf.lisp 72 | kbdmac.lisp 73 | icom.lisp 74 | scribe.lisp 75 | pascal.lisp 76 | edit-defs.lisp 77 | auto-save.lisp 78 | register.lisp 79 | xcoms.lisp 80 | unixcoms.lisp 81 | mh.lisp 82 | highlight.lisp 83 | dired.lisp 84 | diredcoms.lisp 85 | bufed.lisp 86 | lisp-lib.lisp 87 | completion.lisp 88 | shell.lisp 89 | debug.lisp 90 | netnews.lisp 91 | bindings.lisp 92 | compilation.order 93 | things-to-do.txt 94 | 95 | @! Files that don't get compiled, but you'd expect to be listed in a .upd file. 96 | @! 97 | @! .../tools/hemcom.lisp 98 | @! .../tools/hemload.lisp 99 | @! ed-integrity.lisp 100 | @! hi-integrity.lisp 101 | @! hemlock.log 102 | @! perq-hemlock.log 103 | @! hemlock.upd 104 | @! 105 | -------------------------------------------------------------------------------- /unused/elisp/README: -------------------------------------------------------------------------------- 1 | This is currently a work-in-progess. 2 | 3 | The aim is to build an environment taht lets most elisp packages run inside 4 | PHemlock. Two things that explicitly will not be handled is "emacs sockets" 5 | and "emacs sub-processes". There may be stubs for them, actuallym, there 6 | will probably be stubs for them. 7 | 8 | Currently, most of the code is horribly uncommented and there's next-to-no 9 | docstrings. This will be fixed, at some point. 10 | 11 | The current files in the implementation, with a description of my 12 | generals thoughts of what should go where: 13 | 14 | base.lisp: This is the "base elisp" implementation. Things here end up 15 | in the ELISP package and should in general be "user visible". 16 | 17 | codewalker.lisp: This is a code walker necessary to wrap "variable 18 | access". It's not the most well-tested piece of code in the 19 | world, but so far it hasn't fallen over on my test cases. 20 | 21 | hemlock-shims.lisp: This is functions that need to interact deeply 22 | with Hemlock (key definitions etc, etc). 23 | 24 | internals.lisp: This is the file for what ends up being needed but not 25 | fitting anywhere else. 26 | 27 | loadup.lisp: Load all files, in something approaching a sensible order. 28 | 29 | packages.lisp: Package definitions. 30 | 31 | read-table.lisp: Readtables and support functions. 32 | 33 | implementation-needed: Contains a tentative list of symbols in GNU 34 | Emacs that may or may not need sensible implementation before 35 | we're done. Theory is, once all built-ins are in place, we can 36 | then bootstrap off whatever files tag along with emacs, should 37 | anyone want to. 38 | 39 | Here are some things to look at before releasing: 40 | [new-bbox] 41 | |Warning: These variables are undefined: 42 | | MAJOR-MODE MODE-NAME 43 | | 44 | | 45 | |Warning: These functions are undefined: 46 | | DEFINE-KEY GET-BUFFER-CREATE MAKE-SPARSE-KEYMAP SET-BUFFER SWITCH-TO-BUFFER 47 | | USE-LOCAL-MAP 48 | 49 | 50 | 51 | 52 | //Ingvar 53 | -------------------------------------------------------------------------------- /unused/struct-ed.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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: /home/david/phemlock/cvsroot/phemlock/unused/struct-ed.lisp,v 1.1 2004-07-09 13:39:14 gbaumann Exp $") 9 | ;;; 10 | ;;; ********************************************************************** 11 | ;;; 12 | ;;; Structures used by constucts in the HEMLOCK package. 13 | ;;; 14 | 15 | (in-package "HEMLOCK") 16 | 17 | ;;; The server-info structure holds information about the connection to a 18 | ;;; particular eval server. For now, we don't separate the background I/O and 19 | ;;; random compiler output. The Notifications port and Terminal_IO will be the 20 | ;;; same identical object. This separation in the interface may be just 21 | ;;; gratuitous pseudo-generality, but it doesn't hurt. 22 | ;;; 23 | (defstruct (server-info 24 | (:print-function 25 | (lambda (s stream d) 26 | (declare (ignore d)) 27 | (format stream "#" (server-info-name s))))) 28 | name ; String name of this server. 29 | port ; Port we send requests to. 30 | ; NullPort if no connection. 31 | notifications ; List of notification objects for operations 32 | ; which have not yet completed. 33 | ts-info ; Ts-Info structure of typescript we use in 34 | ; "background" buffer. 35 | buffer ; Buffer "background" typescript is in. 36 | slave-ts ; Ts-Info used in "Slave Lisp" buffer 37 | ; (formerly the "Lisp Listener" buffer). 38 | slave-buffer ; "Slave Lisp" buffer for slave's *terminal-io*. 39 | errors ; List of structures describing reported errors. 40 | error-mark) ; Pointer after last error edited. 41 | -------------------------------------------------------------------------------- /src/dylan.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; This file contains a minimal dylan mode. 11 | ;;; 12 | (in-package :hemlock) 13 | 14 | ;;; hack .. 15 | 16 | (setf (getstring "dylan" *mode-names*) nil) 17 | 18 | 19 | (defmode "Dylan" :major-p t) 20 | (defcommand "Dylan Mode" (p) 21 | "Put the current buffer into \"Dylan\" mode." 22 | "Put the current buffer into \"Dylan\" mode." 23 | (declare (ignore p)) 24 | (setf (buffer-major-mode (current-buffer)) "Dylan")) 25 | 26 | (define-file-type-hook ("dylan") (buffer type) 27 | (declare (ignore type)) 28 | (setf (buffer-major-mode buffer) "Dylan")) 29 | 30 | (defhvar "Indent Function" 31 | "Indentation function which is invoked by \"Indent\" command. 32 | It must take one argument that is the prefix argument." 33 | :value #'generic-indent 34 | :mode "Dylan") 35 | 36 | (defhvar "Auto Fill Space Indent" 37 | "When non-nil, uses \"Indent New Comment Line\" to break lines instead of 38 | \"New Line\"." 39 | :mode "Dylan" :value t) 40 | 41 | (defhvar "Comment Start" 42 | "String that indicates the start of a comment." 43 | :mode "Dylan" :value "//") 44 | 45 | (defhvar "Comment End" 46 | "String that ends comments. Nil indicates #\newline termination." 47 | :mode "Dylan" :value nil) 48 | 49 | (defhvar "Comment Begin" 50 | "String that is inserted to begin a comment." 51 | :mode "Dylan" :value "// ") 52 | 53 | (bind-key "Delete Previous Character Expanding Tabs" #k"backspace" 54 | :mode "Dylan") 55 | (bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Dylan") 56 | 57 | ;;; hacks... 58 | 59 | (shadow-attribute :scribe-syntax #\< nil "Dylan") 60 | (shadow-attribute :scribe-syntax #\> nil "Dylan") 61 | (bind-key "Self Insert" #k"\>" :mode "Dylan") 62 | (bind-key "Scribe Insert Bracket" #k")" :mode "Dylan") 63 | (bind-key "Scribe Insert Bracket" #k"]" :mode "Dylan") 64 | (bind-key "Scribe Insert Bracket" #k"}" :mode "Dylan") 65 | -------------------------------------------------------------------------------- /unused/hi-integrity.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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: /home/david/phemlock/cvsroot/phemlock/unused/hi-integrity.lisp,v 1.1 2004-07-09 13:39:13 gbaumann Exp $") 9 | ;;; 10 | ;;; ********************************************************************** 11 | ;;; 12 | ;;; Written by Skef Wholey 13 | ;;; 14 | ;;; Hack to check a buffer's integrity. 15 | ;;; 16 | (in-package "HEMLOCK-INTERNALS") 17 | 18 | (defun checkit (&optional (buffer (current-buffer))) 19 | "Returns NIL if the buffer's region is OK, or a losing line if it ain't. 20 | If a malformed mark is found in the mark list it is returned as the 21 | second value." 22 | (do ((line (mark-line (buffer-start-mark buffer)) (line-next line)) 23 | (previous nil line) 24 | (lines nil (cons line lines))) 25 | ((null line) nil) 26 | (unless (eq (line-%buffer line) buffer) 27 | (format t "~%Oh, Man! It's in the wrong buffer!~%") 28 | (return line)) 29 | (when (member line lines) 30 | (format t "~%Oh, Man! It's circular!~%") 31 | (return line)) 32 | (unless (eq previous (line-previous line)) 33 | (format t "~%Oh, Man! A back-pointer's screwed up!~%") 34 | (return line)) 35 | (when (and previous (>= (line-number previous) (line-number line))) 36 | (format t "~%Oh, Man! A line number is screwed up!~%") 37 | (return line)) 38 | (let ((res 39 | (do ((m (line-marks line) (cdr m))) 40 | ((null m) nil) 41 | (unless (<= 0 (mark-charpos (car m)) (line-length line)) 42 | (format t "~%Oh, Man! A mark is pointing into hyperspace!~%") 43 | (return (car m))) 44 | (unless (member (mark-%kind (car m)) 45 | '(:left-inserting :right-inserting)) 46 | (format t "~%Oh, Man! A mark's type is bogus!.~%") 47 | (return (car m))) 48 | (unless (eq (mark-line (car m)) line) 49 | (format t "~%Oh, Man! A mark's line pointer is messed up!~%") 50 | (return (car m)))))) 51 | (when res 52 | (return (values line res)))))) 53 | -------------------------------------------------------------------------------- /unused/spell/constants.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package "SPELL") 4 | 5 | (defconstant +spell-deleted-entry+ #xFFFF) 6 | 7 | ;;; The next number (using 6 bits) is 63, and that's pretty silly because 8 | ;;; "supercalafragalistic" is less than 31 characters long. 9 | ;;; 10 | (defconstant +max-entry-length+ 31 11 | "This the maximum number of characters an entry may have.") 12 | 13 | 14 | 15 | ;;; These are the eleven bits of a computed hash that are stored as part of 16 | ;;; an entries descriptor unit. The shifting constant is how much the 17 | ;;; eleven bits need to be shifted to the right, so they take up the upper 18 | ;;; eleven bits of one 16-bit element in a descriptor unit. 19 | ;;; 20 | (defconstant +new-hash-byte+ (byte 11 13)) 21 | (defconstant +stored-hash-byte+ (byte 11 5)) 22 | 23 | 24 | ;;; The next two constants are used to extract information from an entry's 25 | ;;; descriptor unit. The first is the two most significant bits of 18 26 | ;;; bits that hold an index into the string table where the entry is 27 | ;;; located. If this is confusing, regard the diagram of the descriptor 28 | ;;; units above. 29 | ;;; 30 | ;;; This is used to break up an 18 bit string table index into two parts 31 | ;;; for storage in a word descriptor unit. See the documentation at the 32 | ;;; top of Spell-Correct.Lisp. 33 | ;;; 34 | (defconstant +whole-index-low-byte+ (byte 16 0)) 35 | (defconstant +whole-index-high-byte+ (byte 2 16)) 36 | 37 | (defconstant +stored-index-high-byte+ (byte 2 14)) 38 | (defconstant +stored-length-byte+ (byte 5 0)) 39 | 40 | (defconstant +spell-alphabet+ 41 | (list #\A #\B #\C #\D #\E #\F #\G #\H 42 | #\I #\J #\K #\L #\M #\N #\O #\P 43 | #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) 44 | 45 | ;;; This is the first thing in a spell binary dictionary file to serve as a 46 | ;;; quick check of its proposed contents. This particular number is 47 | ;;; "BILLS" on a calculator held upside-down. 48 | ;;; 49 | (defconstant +magic-file-id+ 57718) 50 | 51 | ;;; These constants are derived from the order things are written to the 52 | ;;; binary dictionary in Spell-Build.Lisp. 53 | ;;; 54 | (defconstant +magic-file-id-loc+ 0) 55 | (defconstant +dictionary-size-loc+ 1) 56 | (defconstant +descriptors-size-loc+ 2) 57 | (defconstant +string-table-size-low-byte-loc+ 3) 58 | (defconstant +string-table-size-high-byte-loc+ 4) 59 | (defconstant +file-header-bytes+ 10) 60 | 61 | ;;; bump this up a bit, but do not lower it. TRY-WORD-ENDINGS depends on 62 | ;;; this value being at least 4. 63 | (defconstant +minimum-try-word-endings-length+ 4) -------------------------------------------------------------------------------- /src/overwrite.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; Written by Bill Chiles. 11 | ;;; 12 | 13 | (in-package :hemlock) 14 | 15 | (defmode "Overwrite") 16 | 17 | (defcommand "Overwrite Mode" (p) 18 | "Printing characters overwrite characters instead of pushing them to the right. 19 | A positive argument turns Overwrite mode on, while zero or a negative 20 | argument turns it off. With no arguments, it is toggled. Use C-Q to 21 | insert characters normally." 22 | "Determine if in Overwrite mode or not and set the mode accordingly." 23 | (setf (buffer-minor-mode (current-buffer) "Overwrite") 24 | (if p 25 | (plusp p) 26 | (not (buffer-minor-mode (current-buffer) "Overwrite"))))) 27 | 28 | 29 | (defcommand "Self Overwrite" (p) 30 | "Replace the next character with the last character typed, 31 | but insert at end of line. With prefix argument, do it that many times." 32 | "Implements ``Self Overwrite'', calling this function is not meaningful." 33 | (let ((char (hemlock-ext:key-event-char *last-key-event-typed*)) 34 | (point (current-point))) 35 | (unless char (editor-error "Can't insert that character.")) 36 | (do ((n (or p 1) (1- n))) 37 | ((zerop n)) 38 | (case (next-character point) 39 | (#\tab 40 | (let ((col1 (mark-column point)) 41 | (col2 (mark-column (mark-after point)))) 42 | (if (= (- col2 col1) 1) 43 | (setf (previous-character point) char) 44 | (insert-character (mark-before point) char)))) 45 | ((#\newline nil) (insert-character point char)) 46 | (t (setf (next-character point) char) 47 | (mark-after point)))))) 48 | 49 | 50 | (defcommand "Overwrite Delete Previous Character" (p) 51 | "Replaces previous character with space, but tabs and newlines are deleted. 52 | With prefix argument, do it that many times." 53 | "Replaces previous character with space, but tabs and newlines are deleted." 54 | (do ((point (current-point)) 55 | (n (or p 1) (1- n))) 56 | ((zerop n)) 57 | (case (previous-character point) 58 | ((#\newline #\tab) (delete-characters point -1)) 59 | ((nil) (editor-error)) 60 | (t (setf (previous-character point) #\space) 61 | (mark-before point))))) 62 | -------------------------------------------------------------------------------- /src/icom.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; This is an italicized comment. 11 | 12 | (in-package :hemlock) 13 | 14 | (defun delete-line-italic-marks (line) 15 | (dolist (m (hi::line-marks line)) 16 | (when (and (hi::fast-font-mark-p m) 17 | (eql (hi::font-mark-font m) 1)) 18 | (delete-font-mark m)))) 19 | 20 | (defun set-comment-font (region font) 21 | (do ((line (mark-line (region-start region)) 22 | (line-next line)) 23 | (end (line-next (mark-line (region-end region))))) 24 | ((eq line end)) 25 | (delete-line-italic-marks line) 26 | (let ((pos (position #\; (the simple-string (line-string line))))) 27 | (when pos 28 | (font-mark line pos font :left-inserting))))) 29 | 30 | (defun delete-italic-marks-region (region) 31 | (do ((line (mark-line (region-start region)) 32 | (line-next line)) 33 | (end (line-next (mark-line (region-end region))))) 34 | ((eq line end)) 35 | (delete-line-italic-marks line))) 36 | 37 | 38 | (defmode "Italic" 39 | :setup-function 40 | #'(lambda (buffer) (set-comment-font (buffer-region buffer) 1)) 41 | :cleanup-function 42 | #'(lambda (buffer) (delete-italic-marks-region (buffer-region buffer)))) 43 | 44 | (define-file-option "Italicize Comments" (buffer value) 45 | (declare (ignore value)) 46 | (setf (buffer-minor-mode buffer "Italic") t)) 47 | 48 | (defcommand "Italic Comment Mode" (p) 49 | "Toggle \"Italic\" mode in the current buffer. When in \"Italic\" mode, 50 | semicolon comments are displayed in an italic font." 51 | "Toggle \"Italic\" mode in the current buffer." 52 | (declare (ignore p)) 53 | (setf (buffer-minor-mode (current-buffer) "Italic") 54 | (not (buffer-minor-mode (current-buffer) "Italic")))) 55 | 56 | 57 | (defcommand "Start Italic Comment" (p) 58 | "Italicize the text in this comment." 59 | "Italicize the text in this comment." 60 | (declare (ignore p)) 61 | (let* ((point (current-point)) 62 | (pos (mark-charpos point)) 63 | (line (mark-line point))) 64 | (delete-line-italic-marks line) 65 | (insert-character point #\;) 66 | (font-mark 67 | line 68 | (or (position #\; (the simple-string (line-string line))) pos) 69 | 1 70 | :left-inserting))) 71 | 72 | (bind-key "Start Italic Comment" #k";" :mode "Italic") 73 | -------------------------------------------------------------------------------- /src/lispdep.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; --------------------------------------------------------------------------- 3 | ;;; Title: Lisp Implementation Dependent Stuff for Hemlock 4 | ;;; Created: 2002-11-07 5 | ;;; Author: Gilbert Baumann 6 | ;;; --------------------------------------------------------------------------- 7 | ;;; (c) copyright 2002 by Gilbert Baumann 8 | 9 | (in-package :hemlock-ext) 10 | 11 | #+CLISP 12 | (progn 13 | (setf custom:*FLOATING-POINT-CONTAGION-ANSI* t) 14 | (setf custom:*WARN-ON-FLOATING-POINT-CONTAGION* nil)) 15 | 16 | (defun getenv (name) 17 | #.(or 18 | #+EXCL '(sys:getenv name) 19 | #+CLISP '(ext:getenv name) 20 | #+CMU '(cdr (assoc name ext:*environment-list* :test #'string=)) 21 | #+scl '(cdr (assoc name ext:*environment-list* :test #'string-equal)) 22 | #+sbcl '(sb-ext:posix-getenv name) 23 | #+openmcl '(ccl::getenv name) 24 | (error "Find an implementation of getenv for your Lisp."))) 25 | 26 | (defmacro without-interrupts (&body body) 27 | `(#+EXCL excl:without-interrupts 28 | #+CMU sys:without-interrupts 29 | #+sbcl sb-sys:without-interrupts 30 | #+openmcl ccl:without-interrupts 31 | #-(or EXCL CMU sbcl openmcl) progn 32 | ,@body)) 33 | 34 | #-(or CMU scl) 35 | (defmacro fixnump (object) 36 | #+EXCL `(excl:fixnump ,object) 37 | #+CLISP `(sys::fixnump ,object) 38 | #-(or EXCL CLISP) `(typep ,object 'fixnum)) 39 | 40 | #-(or cmu scl) 41 | (defun file-writable (pathname) 42 | "File-writable accepts a pathname and returns T if the current 43 | process can write it, and NIL otherwise. Also if the file does 44 | not exist return T." 45 | (handler-case (let ((io (open pathname 46 | :direction :output 47 | :if-exists :append 48 | :if-does-not-exist nil))) 49 | (if io 50 | (close io :abort t) 51 | ;; more complicate situation: 52 | ;; we want test if we can create the file. 53 | (let ((io (open pathname 54 | :direction :output 55 | :if-exists nil 56 | :if-does-not-exist :create))) 57 | (if io 58 | (progn 59 | (close io) 60 | (delete-file io)) 61 | t)))) 62 | (file-error (err) 63 | (declare (ignore err)) 64 | nil)) ) 65 | 66 | (defmacro without-gcing (&body body) 67 | `(progn ,@body)) 68 | -------------------------------------------------------------------------------- /src/decls.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :hemlock-internals) 4 | 5 | ;;; Use #.*fast* for optimizations. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (defparameter *fast* 9 | '(declare (optimize speed))) 10 | 11 | (defparameter *fast* 12 | '(declare))) 13 | 14 | 15 | ;; Since the declaim form for functions looks clumsy and is 16 | ;; syntax-wise different from defun, we define us a new declfun, which 17 | ;; fixes this. 18 | 19 | (defmacro declfun (name lambda-list) 20 | `(declaim (ftype (function 21 | ,(let ((q lambda-list) 22 | res) 23 | (do () ((or (null q) 24 | (member (car q) '(&optional &rest &key)))) 25 | (push 't res) 26 | (pop q)) 27 | (when (eq (car q) '&optional) 28 | (push '&optional res) 29 | (pop q) 30 | (do () ((or (null q) 31 | (member (car q) '(&rest &key)))) 32 | (push 't res))) 33 | (when (eq (car q) '&rest) 34 | (push '&rest res) 35 | (pop q) 36 | (push 't res) 37 | (pop q)) 38 | (when (eq (car q) '&key) 39 | (push '&key res) 40 | (pop q) 41 | (do () ((or (null q) 42 | (member (car q) '(&allow-other-keys)))) 43 | (push (list (intern (string (if (consp (car q)) 44 | (if (consp (caar q)) 45 | (caaar q) 46 | (caar q)) 47 | (car q))) 48 | :keyword) 49 | 't) 50 | res) 51 | (pop q))) 52 | (when (eq (car q) '&allow-other-keys) 53 | (push '&allow-other-keys res) 54 | (pop q)) 55 | (reverse res)) 56 | t) 57 | ,name))) 58 | 59 | (declfun window-buffer (window)) 60 | (declfun change-to-buffer (buffer)) ;filecoms.lisp 61 | (declfun hemlock::to-line-comment (mark start)) ;defined in comments.lisp used in lispbuf.lisp -------------------------------------------------------------------------------- /src/repl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | (in-package :hi) 8 | 9 | 10 | ;;;; PREPL/background buffer integration 11 | 12 | (declaim (special hi::*in-hemlock-slave-p* 13 | hemlock::*master-machine-and-port* 14 | hemlock::*original-terminal-io*)) 15 | 16 | (defun need-to-redirect-debugger-io (stream) 17 | (eq stream hemlock::*original-terminal-io*)) 18 | 19 | (defun call-with-typeout-for-thread-debugger (cont) 20 | (with-new-event-loop () 21 | (let ((prepl:*entering-prepl-debugger-hook* nil) 22 | (hi::*in-hemlock-slave-p* t) 23 | (hemlock.wire:*current-wire* :not-yet)) 24 | (hemlock::connect-to-editor-for-background-thread 25 | (car hemlock::*master-machine-and-port*) 26 | (cadr hemlock::*master-machine-and-port*)) 27 | (dispatch-events-no-hang) 28 | (do () 29 | ((not (eq hemlock.wire:*current-wire* :not-yet))) 30 | (dispatch-events) 31 | (write-line "Thread waiting for connection to master..." 32 | hemlock::*original-terminal-io*) 33 | (force-output hemlock::*original-terminal-io*)) 34 | (with-typeout-pop-up-in-master 35 | (*terminal-io* (format nil "Slave thread ~A" 36 | (bt:thread-name (bt:current-thread)))) 37 | (call-with-standard-synonym-streams cont))))) 38 | 39 | ;;; Setup an a connection to the editor for the current thread, and 40 | ;;; create an editor buffer for I/O and return the client stream. 41 | (defun typeout-for-thread () 42 | (assert (or (not (boundp '*event-base*)) (not *event-base*))) 43 | (setf *event-base* (make-event-loop *connection-backend*)) 44 | (setf hi::*in-hemlock-slave-p* t) 45 | (let ((hemlock.wire:*current-wire* :not-yet)) 46 | (hemlock::connect-to-editor-for-background-thread 47 | (car hemlock::*master-machine-and-port*) 48 | (cadr hemlock::*master-machine-and-port*)) 49 | (dispatch-events-no-hang) 50 | (do () 51 | ((not (eq hemlock.wire:*current-wire* :not-yet))) 52 | (dispatch-events) 53 | (write-line "Thread waiting for connection to master..." 54 | hemlock::*original-terminal-io*) 55 | (force-output hemlock::*original-terminal-io*)) 56 | (let* ((name (format nil "Slave thread ~A" 57 | (bt:thread-name (bt:current-thread)))) 58 | (ts-data (hemlock.wire:remote-value hemlock.wire:*current-wire* 59 | (hemlock::%make-extra-typescript-buffer name)))) 60 | (hemlock::connect-stream ts-data hemlock.wire:*current-wire*)))) 61 | 62 | -------------------------------------------------------------------------------- /src/request.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :hemlock) 4 | 5 | 6 | ;;; REQUEST-SERVER structure 7 | ;;; 8 | ;;; Just a simple handle on the socket and system:serve-event handler that make 9 | ;;; up a request server. 10 | ;;; 11 | (defstruct (request-server 12 | (:print-function %print-request-server)) 13 | listener) 14 | 15 | (defun %print-request-server (rs stream depth) 16 | (declare (ignore depth)) 17 | (print-unreadable-object (rs stream :type t) 18 | (format stream "for ~D" (request-server-listener rs)))) 19 | 20 | ;;; *request-server-interface* 21 | ;;; 22 | ;;; Address to listen on for connections from slaves. 23 | ;;; 24 | (defvar *request-server-interface* "127.0.0.1") 25 | 26 | ;;; CREATE-REQUEST-SERVER -- Public. 27 | ;;; 28 | ;;; Create a TCP/IP listener on the given port. If anyone tries to connect to 29 | ;;; it, call NEW-CONNECTION to do the connecting. 30 | ;;; 31 | (defun create-request-server (&optional port) 32 | "Create a request server on the given port. Whenever anyone connects to it, 33 | call the given function with the newly created wire and the address of the 34 | connector. If the function returns NIL, the connection is destroyed; 35 | otherwise, it is accepted. This returns a manifestation of the server that 36 | DESTROY-REQUEST-SERVER accepts to kill the request server." 37 | (let ((listener 38 | (make-tcp-listener 39 | "request server" 40 | *request-server-interface* 41 | port 42 | :acceptor (lambda (connection) 43 | (hemlock.wire:make-wire 44 | (make-connection-device connection))) 45 | :buffer t))) 46 | (values (make-request-server :listener listener) 47 | (connection-port listener)))) 48 | 49 | ;;; DESTROY-REQUEST-SERVER -- Public. 50 | ;;; 51 | ;;; Removes the request server from SERVER's list of file descriptors and 52 | ;;; closes the socket behind it. 53 | ;;; 54 | (defun destroy-request-server (server) 55 | "Quit accepting connections to the given request server." 56 | (delete-connection (request-server-listener server)) 57 | nil) 58 | 59 | ;;; CONNECT-TO-REMOTE-SERVER -- Public. 60 | ;;; 61 | ;;; Just like the doc string says, connect to a remote server. A handler is 62 | ;;; installed to handle return values, etc. 63 | ;;; 64 | (defun connect-to-remote-server (hostname port on-connected &optional on-death) 65 | (declare (ignore on-death)) ;fixme? 66 | "Connect to a remote request server addressed with the given host and port 67 | pair. This returns the created wire." 68 | (let (wire) 69 | (flet ((sentinel (connection event) 70 | (ecase event 71 | (:initialized 72 | (setf wire (hemlock.wire:make-wire 73 | (make-connection-device 74 | connection)))) 75 | (:connected 76 | (funcall on-connected wire))))) 77 | (make-tcp-connection "Connection to master" 78 | hostname 79 | port 80 | :sentinel #'sentinel)))) 81 | -------------------------------------------------------------------------------- /src/termcap.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; Written by Bill Chiles 11 | ;;; 12 | ;;; Terminal Capability 13 | 14 | (in-package :hemlock-internals) 15 | 16 | ;;; This stuff used to parse a Termcap file. Now it's just a 17 | ;;; compatibility layer over the Terminfo code. At some point this 18 | ;;; should be deleted entirely. 19 | 20 | (defvar *termcaps* ()) 21 | 22 | (defun termcap (name) 23 | (funcall (cdr (assoc name *termcaps* :test #'eq)))) 24 | 25 | (defmacro deftermcap (name type cl-name terminfo-name) 26 | (declare (ignore name type)) 27 | `(progn (push (cons ',cl-name (lambda () ,(intern (symbol-name terminfo-name) :hemlock.terminfo))) *termcaps*))) 28 | 29 | (deftermcap "is" :string :init-string init-2string) 30 | (deftermcap "if" :string :init-file init-file) 31 | (deftermcap "ti" :string :init-cursor-motion enter-ca-mode) 32 | (deftermcap "te" :string :end-cursor-motion exit-ca-mode) 33 | (deftermcap "al" :string :open-line insert-line) 34 | (deftermcap "am" :boolean :auto-margins-p auto-right-margin) 35 | (deftermcap "ce" :string :clear-to-eol clr-eol) 36 | (deftermcap "cl" :string :clear-display clear-screen) 37 | #+nil (deftermcap "cm" :string :cursor-motion cursor-address) 38 | (deftermcap "co" :number :columns columns) 39 | (deftermcap "dc" :string :delete-char delete-character) 40 | (deftermcap "dm" :string :init-delete-mode enter-delete-mode) 41 | (deftermcap "ed" :string :end-delete-mode clr-eos) 42 | (deftermcap "dl" :string :delete-line delete-line) 43 | (deftermcap "im" :string :init-insert-mode enter-insert-mode) 44 | (deftermcap "ic" :string :init-insert-char insert-character) 45 | (deftermcap "ip" :string :end-insert-char insert-padding) 46 | (deftermcap "ei" :string :end-insert-mode exit-insert-mode) 47 | (deftermcap "li" :number :lines lines) 48 | (deftermcap "so" :string :init-standout-mode enter-standout-mode) 49 | (deftermcap "se" :string :end-standout-mode exit-standout-mode) 50 | #+nil(deftermcap "tc" :string :similar-terminal) 51 | (deftermcap "os" :boolean :overstrikes over-strike) 52 | (deftermcap "ul" :boolean :underlines transparent-underline) 53 | 54 | ;;; font related stuff, added by William 55 | (deftermcap "ae" :string :end-alternate-char-set exit-alt-charset-mode) 56 | (deftermcap "as" :string :start-alternate-char-set enter-alt-charset-mode) 57 | (deftermcap "mb" :string :start-blinking-attribute enter-blink-mode) 58 | (deftermcap "md" :string :start-bold-attribute enter-bold-mode) 59 | (deftermcap "me" :string :end-all-attributes exit-attribute-mode) 60 | (deftermcap "mh" :string :start-half-bright-attribute enter-dim-mode) 61 | (deftermcap "mk" :string :start-blank-attribute enter-secure-mode) 62 | (deftermcap "mp" :string :start-protected-attribute enter-protected-mode) 63 | (deftermcap "mr" :string :start-reverse-video-attribute enter-reverse-mode) 64 | (deftermcap "ue" :string :end-underscore-mode exit-underline-mode) 65 | (deftermcap "us" :string :start-underscore-mode enter-underline-mode) 66 | -------------------------------------------------------------------------------- /src/spell-rt.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; Written by Bill Chiles 11 | ;;; 12 | ;;; This file contains system dependent primitives for the spelling checking/ 13 | ;;; correcting code in Spell-Correct.Lisp, Spell-Augment.Lisp, and 14 | ;;; Spell-Build.Lisp. 15 | 16 | (defpackage :spell 17 | (:use :cl) 18 | #+sbcl (:shadow cl:defconstant) 19 | (:export spell-try-word spell-root-word spell-collect-close-words 20 | maybe-read-spell-dictionary correct-spelling max-entry-length 21 | spell-read-dictionary spell-add-entry spell-root-flags 22 | spell-remove-entry)) 23 | 24 | (in-package :spell) 25 | 26 | #+sbcl 27 | (defmacro defconstant (symbol value &rest rest) 28 | `(sb-int:defconstant-eqx ,symbol ,value #'equal ,@rest)) 29 | 30 | 31 | ;;;; Spell structure referencing and setting 32 | 33 | (eval-when (:compile-toplevel :execute) 34 | 35 | (defmacro sapref (sap offset) 36 | `(let ((index (* ,offset 2))) 37 | (logior (aref ,sap index) 38 | (ash (aref ,sap (+ index 1)) 8)))) 39 | 40 | (defsetf sapref (sap offset) (value) 41 | `(let ((index (* ,offset 2))) 42 | (setf (aref ,sap index) (logand ,value #xff)) 43 | (setf (aref ,sap (+ index 1)) (ash ,value -8)))) 44 | 45 | 46 | 47 | ;;;; Primitive String Hashing 48 | 49 | ;;; STRING-HASH employs the instruction SXHASH-SIMPLE-SUBSTRING which takes 50 | ;;; an end argument, so we do not have to use SXHASH. SXHASH would mean 51 | ;;; doing a SUBSEQ of entry. 52 | ;;; 53 | (defmacro string-hash (string length) 54 | #+(or cmu scl) 55 | `(lisp::%sxhash-simple-substring ,string ,length) 56 | #-(or cmu scl) 57 | `(if (= ,length (length ,string)) 58 | (sxhash ,string) 59 | (sxhash (subseq ,string 0 ,length)))) 60 | 61 | ) ;eval-when 62 | 63 | (defun sap-replace (dst-string src-string src-start dst-start dst-end) 64 | (do ((i src-start (1+ i)) 65 | (j dst-start (1+ j))) 66 | ((>= j dst-end)) 67 | (let ((code (if (stringp src-string) 68 | (char-code (schar src-string i)) 69 | (aref src-string i)))) 70 | (if (stringp dst-string) 71 | (setf (schar dst-string j) (code-char code)) 72 | (setf (aref dst-string j) code))))) 73 | 74 | 75 | ;;;; Binary Dictionary File I/O 76 | 77 | (defun open-dictionary (f) 78 | (open f :direction :input :element-type '(unsigned-byte 8))) 79 | 80 | (defun close-dictionary (stream) 81 | (close stream)) 82 | 83 | (defun read-dictionary-structure (stream bytes) 84 | (let* ((structure (make-array bytes :element-type '(unsigned-byte 8))) 85 | (count (read-sequence structure stream))) 86 | (unless (= bytes count) 87 | (error "Reading dictionary structure failed.")) 88 | structure)) 89 | 90 | (defun read-dictionary-structure-u32 (stream size) 91 | (let ((structure (make-array size :element-type '(unsigned-byte 32)))) 92 | (dotimes (i size) 93 | (let ((value (logior (read-byte stream) 94 | (ash (read-byte stream) 8) 95 | (ash (read-byte stream) 16) 96 | (ash (read-byte stream) 24)))) 97 | (setf (aref structure i) value))) 98 | structure)) 99 | -------------------------------------------------------------------------------- /unused/elisp/hemlock-shims.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package "ELISP") 4 | 5 | (cl:defun mangle-key (key) 6 | "Turn a CL-elisp key designator to a PHemlock KEY-EVENT" 7 | (typecase key 8 | ; (string (with-input-from-string (stream key) 9 | ; (let ((*readtable* elisp-internals:*elisp-readtable*)) 10 | ; (elisp-internals::read-string-char stream :event)))) 11 | (string (map 'vector #'mangle-key key)) 12 | ((or vector array) 13 | (map 'vector #'mangle-key key)) 14 | (hemlock-ext:key-event key) 15 | ((or integer character) 16 | (multiple-value-bind (ismeta ischar) (truncate (if (characterp key) 17 | (char-code key) 18 | key) 19 | 128) 20 | (cl:let ((charspec (if (cl:= 1 ismeta) (list :meta)))) 21 | (when (< ischar 32) 22 | (push :control charspec) 23 | (setq ischar (1- (+ ischar (char-code #\a))))) 24 | (push (code-char ischar) charspec) 25 | (elisp-internals::emit-character (reverse charspec) :event) 26 | ))))) 27 | 28 | (cl:defun global-set-key (key command) 29 | (let ((key (mangle-key key))) 30 | (bind-key (string command) key :global))) 31 | 32 | (cl:defun local-set-key (key command) 33 | (let ((key (mangle-key key))) 34 | (bind-key (string command) key :mode major-mode))) 35 | 36 | (cl:defun use-local-map (keymap) 37 | (cond ((and (listp keymap) 38 | (eq (car keymap) 'keymap)) 39 | (cl:let ((has-menu-name (stringp (cadr keymap)))) 40 | (let ((char-table (if has-menu-name 41 | (if (vectorp (caddr keymap)) 42 | (caddr keymap)) 43 | (if (vectorp (cadr keymap)) 44 | (cadr keymap)))) 45 | (the-alist (if has-menu-name 46 | (if (vectorp (caddr keymap)) 47 | (cdddr keymap)) 48 | (if (vectorp (cadr keymap)) 49 | (cddr keymap))))) 50 | ; iterate through the relevant sections 51 | ))) 52 | ((symbolp keymap) 53 | (use-local-map (eval keymap))))) 54 | 55 | (cl:defun get-buffer-create (buffer-name) 56 | (or (getstring buffer-name *buffer-names*) 57 | (make-buffer buffer-name))) 58 | 59 | (cl:defun get-buffer (buffer-name) 60 | (getstring buffer-name *buffer-names*)) 61 | 62 | (cl:defun commandp (function-designator) 63 | (typecase function-designator 64 | (symbol (hemlock-internals:commandp (getstring (string-downcase (string function-designator)) hemlock-internals:*command-names*))) 65 | (function nil) ; Bug, but as far as I can tell, we can't portably 66 | ; extract the name from the function object 67 | (string (hemlock-internals:commandp (getstring (string-downcase function-designator) hemlock-internals:*command-names*))) 68 | (t nil))) 69 | 70 | (cl:defun bolp () 71 | (= 0 (hemlock-internals:mark-charpos (hemlock-internals:current-point)))) 72 | 73 | (cl:defun bobp () 74 | (and (= 0 (hemlock-internals::line-number (hemlock-internals:mark-line (hemlock-internals:current-point)))) 75 | (bolp))) 76 | 77 | (cl:defun abort-recursive-edit () 78 | (and (hemlock-internals:in-recursive-edit) 79 | (hemlock-internals:exit-recursive-edit))) 80 | -------------------------------------------------------------------------------- /src/patch.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :clim-internals) 4 | 5 | (in-package :clim-clx) 6 | 7 | #+NIL 8 | (defmethod medium-draw-text* ((medium clx-medium) string x y 9 | start end 10 | align-x align-y 11 | toward-x toward-y transform-glyphs) 12 | (declare (ignore toward-x toward-y transform-glyphs)) 13 | (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) 14 | x y) 15 | (with-clx-graphics (medium) 16 | (when (characterp string) 17 | (setq string (make-string 1 :initial-element string))) 18 | (when (null end) (setq end (length string))) 19 | (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) 20 | (text-size medium string :start start :end end) 21 | (declare (ignore x-cursor y-cursor)) 22 | (unless (and (eq align-x :left) (eq align-y :baseline)) 23 | (setq x (- x (ecase align-x 24 | (:left 0) 25 | (:center (round text-width 2)) 26 | (:right text-width)))) 27 | (setq y (ecase align-y 28 | (:top (+ y (xlib:font-ascent (xlib:gcontext-font gc)))) 29 | (:center (+ y baseline (- (floor text-height 2)))) 30 | (:baseline y) 31 | (:bottom (+ y baseline (- text-height))))))) 32 | (let ((x (round-coordinate x)) 33 | (y (round-coordinate y))) 34 | (when (and (<= #x-8000 x #x7FFF) 35 | (<= #x-8000 y #x7FFF)) 36 | (multiple-value-bind (halt width) 37 | (xlib:draw-glyphs mirror gc x y string 38 | :start start :end end 39 | :translate #'translate))))))) 40 | 41 | #+NIL 42 | (defmethod medium-draw-text* ((medium clx-medium) string x y 43 | start end 44 | align-x align-y 45 | toward-x toward-y transform-glyphs) 46 | (declare (ignore toward-x toward-y transform-glyphs)) 47 | (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) 48 | x y) 49 | (with-clx-graphics (medium) 50 | (when (characterp string) 51 | (setq string (make-string 1 :initial-element string))) 52 | (when (null end) (setq end (length string))) 53 | (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) 54 | (unless (and (eq align-x :left) 55 | (member align-y '(:baseline :top))) 56 | (text-size medium string :start start :end end)) 57 | (declare (ignore x-cursor y-cursor)) 58 | (unless (and (eq align-x :left) (eq align-y :baseline)) 59 | (setq x (- x (ecase align-x 60 | (:left 0) 61 | (:center (round text-width 2)) 62 | (:right text-width)))) 63 | (setq y (ecase align-y 64 | (:top (+ y (xlib:font-ascent (xlib:gcontext-font gc)))) 65 | (:center (+ y baseline (- (floor text-height 2)))) 66 | (:baseline y) 67 | (:bottom (+ y baseline (- text-height))))))) 68 | (let ((x (round-coordinate x)) 69 | (y (round-coordinate y))) 70 | (when (and (<= #x-8000 x #x7FFF) 71 | (<= #x-8000 y #x7FFF)) 72 | (multiple-value-bind (halt width) 73 | (xlib:draw-glyphs mirror gc x y string 74 | :start start :end end 75 | :translate #'translate))))))) -------------------------------------------------------------------------------- /unused/elisp/codewalker.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; The code walker should ideally be in ELISP-INTERNALS, however 4 | ;;; getting it there won't be trivial, so ignoring that for now. 5 | (in-package "ELISP") 6 | 7 | (cl:defun walk-code (form &optional lexicals) 8 | (cond ((null form) nil) 9 | ((numberp form) form) 10 | ((stringp form) form) 11 | ((atom form) (if (member form lexicals) 12 | form 13 | `(elisp-value ',form))) 14 | (t (cl:let ((head (car form)) 15 | (rest (cdr form))) 16 | (cond ((eq head 'lexical-let) 17 | (cl:let ((bindings (append lexicals 18 | (mapcar #'(lambda (x) 19 | (cl:if (symbolp x) 20 | x 21 | (car x))) 22 | (car rest)))) 23 | (tail (cdr rest))) 24 | (cons head 25 | (cons (mapcar #'(lambda (form) 26 | (walk-code form lexicals)) 27 | (car rest)) 28 | (mapcar #'(lambda (form) 29 | (walk-code form bindings)) 30 | tail))))) 31 | ((eq head 'let) 32 | (cons head (cons (mapcar #'(lambda (form) 33 | (walk-code form lexicals)) 34 | (car rest)) 35 | (mapcar #'(lambda (form) 36 | (walk-code form lexicals)) 37 | (cdr rest))))) 38 | ((member head '(defun defmacro)) 39 | (cl:let ((name (car rest)) 40 | (new-vars 41 | (cl:loop for sym in (cadr rest) 42 | if (not 43 | (member sym '(&optional &rest 44 | &aux &key))) 45 | collect sym)) 46 | (forms (cddr rest)) 47 | (vars (cadr rest))) 48 | `(,head ,name ,vars 49 | ,@(mapcar 50 | #'(lambda (form) 51 | (walk-code form 52 | (append lexicals new-vars))) 53 | forms)))) 54 | ((eq head 'cond) 55 | (cons head 56 | (cl:loop for cond-form in rest 57 | collect 58 | (cl:loop for form in cond-form 59 | collect (walk-code form lexicals))))) 60 | ((eq head 'quote) 61 | (cons head rest)) 62 | ((member head '(setq setf)) 63 | (cons head 64 | (loop for symbol in rest 65 | for toggle = t then (not toggle) 66 | if toggle 67 | collect symbol 68 | else 69 | collect (walk-code symbol lexicals)))) 70 | (t (cons head (mapcar #'(lambda (form) 71 | (walk-code form lexicals)) 72 | rest)))))))) 73 | 74 | -------------------------------------------------------------------------------- /src/debug.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; Slave debugging 4 | 5 | (in-package :hemlock) 6 | 7 | 8 | (defvar *slave-stack-frames* nil) 9 | (defvar *slave-stack-frames-end* nil) 10 | ;;; 11 | 12 | (defstruct (slave-stack-frame 13 | (:constructor make-slave-stack-frame (label remote-frame))) 14 | label 15 | remote-frame) 16 | 17 | 18 | ;;; This is the debug buffer if it exists. 19 | ;;; 20 | (defvar *debug-buffer* nil) 21 | 22 | ;;; This is the cleanup method for deleting *debug-buffer*. 23 | ;;; 24 | (defun delete-debug-buffers (buffer) 25 | (when (eq buffer *debug-buffer*) 26 | (setf *debug-buffer* nil) 27 | (setf *slave-stack-frames* nil))) 28 | 29 | 30 | ;;;; Commands. 31 | 32 | (defmode "Debug" :major-p t 33 | :documentation "Debug mode presents a list of slave symbols.") 34 | 35 | (defcommand "Debug Quit" (p) 36 | "Kill the debug buffer." 37 | "" 38 | (declare (ignore p)) 39 | (when *debug-buffer* (delete-buffer-if-possible *debug-buffer*))) 40 | 41 | (defun slave-stack-frame-from-mark (mark) 42 | ) 43 | 44 | (defun refresh-debug (buf entries) 45 | (with-writable-buffer (buf) 46 | (delete-region (buffer-region buf)) 47 | (setf *slave-stack-frames-end* (length entries)) 48 | (setf *slave-stack-frames* (coerce entries 'vector)) 49 | (with-output-to-mark (s (buffer-point buf)) 50 | (iter:iter (iter:for entry in entries) 51 | (iter:for i from 0) 52 | (debug-write-line i entry s))))) 53 | 54 | (defvar *debug-context* nil) 55 | 56 | (defun make-debug-buffer (context entries impl thread) 57 | (let ((buf (or *debug-buffer* 58 | (make-buffer (format nil "Slave Debugger ~A" impl thread) 59 | :modes '("Debug"))))) 60 | (setf *debug-buffer* buf) 61 | (setf *debug-context* context) 62 | (refresh-debug buf 63 | (mapcar (lambda (entry) 64 | (make-slave-stack-frame (car entry) 65 | (cdr entry))) 66 | entries)) 67 | (let ((fields (buffer-modeline-fields *debug-buffer*))) 68 | (setf (cdr (last fields)) 69 | (list (or (modeline-field :debug-cmds) 70 | (make-modeline-field 71 | :name :debug-cmds :width 18 72 | :function 73 | #'(lambda (buffer window) 74 | (declare (ignore buffer window)) 75 | " Type ? for help."))))) 76 | (setf (buffer-modeline-fields *debug-buffer*) fields)) 77 | (buffer-start (buffer-point buf)) 78 | (change-to-buffer buf))) 79 | 80 | (defun debug-write-line (i entry s) 81 | (format s "~D: ~A~%" i (slave-stack-frame-label entry))) 82 | 83 | (defun debug-using-master (&optional (start 0) (end 10)) 84 | (if prepl:*debugging-context* 85 | (let ((frames 86 | (mapcar (lambda (frame) 87 | (cons (with-output-to-string (s) 88 | (conium:print-frame frame s)) 89 | (hemlock.wire:make-remote-object frame))) 90 | (conium:compute-backtrace start end))) 91 | (context nil 92 | #+nil (hemlock.wire:make-remote-object 93 | prepl:*debugging-context*)) 94 | ;; fixme: show the slave name rather than just the impl type 95 | (impl (lisp-implementation-type)) 96 | (thread (bordeaux-threads:thread-name 97 | (bordeaux-threads:current-thread)))) 98 | (hemlock::eval-in-master 99 | `(make-debug-buffer ',context ',frames ',impl ',thread))) 100 | (prepl:debugger nil nil (lambda () (debug-using-master start end))))) 101 | -------------------------------------------------------------------------------- /resources/XKeysymDB: -------------------------------------------------------------------------------- 1 | ! $XConsortium: XKeysymDB,v 1.2 91/06/18 13:43:07 rws Exp $ 2 | 3 | hpmute_acute :100000A8 4 | hpmute_grave :100000A9 5 | hpmute_asciicircum :100000AA 6 | hpmute_diaeresis :100000AB 7 | hpmute_asciitilde :100000AC 8 | hplira :100000AF 9 | hpguilder :100000BE 10 | hpYdiaeresis :100000EE 11 | hpIO :100000EE 12 | hplongminus :100000F6 13 | hpblock :100000FC 14 | apLineDel :1000FF00 15 | apCharDel :1000FF01 16 | apCopy :1000FF02 17 | apCut :1000FF03 18 | apPaste :1000FF04 19 | apMove :1000FF05 20 | apGrow :1000FF06 21 | apCmd :1000FF07 22 | apShell :1000FF08 23 | apLeftBar :1000FF09 24 | apRightBar :1000FF0A 25 | apLeftBox :1000FF0B 26 | apRightBox :1000FF0C 27 | apUpBox :1000FF0D 28 | apDownBox :1000FF0E 29 | apPop :1000FF0F 30 | apRead :1000FF10 31 | apEdit :1000FF11 32 | apSave :1000FF12 33 | apExit :1000FF13 34 | apRepeat :1000FF14 35 | hpModelock1 :1000FF48 36 | hpModelock2 :1000FF49 37 | hpReset :1000FF6C 38 | hpSystem :1000FF6D 39 | hpUser :1000FF6E 40 | hpClearLine :1000FF6F 41 | hpInsertLine :1000FF70 42 | hpDeleteLine :1000FF71 43 | hpInsertChar :1000FF72 44 | hpDeleteChar :1000FF73 45 | hpBackTab :1000FF74 46 | hpKP_BackTab :1000FF75 47 | apKP_parenleft :1000FFA8 48 | apKP_parenright :1000FFA9 49 | 50 | I2ND_FUNC_L :10004001 51 | I2ND_FUNC_R :10004002 52 | IREMOVE :10004003 53 | IREPEAT :10004004 54 | IA1 :10004101 55 | IA2 :10004102 56 | IA3 :10004103 57 | IA4 :10004104 58 | IA5 :10004105 59 | IA6 :10004106 60 | IA7 :10004107 61 | IA8 :10004108 62 | IA9 :10004109 63 | IA10 :1000410A 64 | IA11 :1000410B 65 | IA12 :1000410C 66 | IA13 :1000410D 67 | IA14 :1000410E 68 | IA15 :1000410F 69 | IB1 :10004201 70 | IB2 :10004202 71 | IB3 :10004203 72 | IB4 :10004204 73 | IB5 :10004205 74 | IB6 :10004206 75 | IB7 :10004207 76 | IB8 :10004208 77 | IB9 :10004209 78 | IB10 :1000420B 79 | IB11 :1000420B 80 | IB12 :1000420C 81 | IB13 :1000420D 82 | IB14 :1000420E 83 | IB15 :1000420F 84 | IB16 :10004210 85 | 86 | DRemove :1000FF00 87 | Dring_accent :1000FEB0 88 | Dcircumflex_accent :1000FE5E 89 | Dcedilla_accent :1000FE2C 90 | Dacute_accent :1000FE27 91 | Dgrave_accent :1000FE60 92 | Dtilde :1000FE7E 93 | Ddiaeresis :1000FE22 94 | 95 | osfCopy :1004FF02 96 | osfCut :1004FF03 97 | osfPaste :1004FF04 98 | osfBackTab :1004FF07 99 | osfBackSpace :1004FF08 100 | osfClear :1004FF0B 101 | osfEscape :1004FF1B 102 | osfAddMode :1004FF31 103 | osfPrimaryPaste :1004FF32 104 | osfQuickPaste :1004FF33 105 | osfPageLeft :1004FF40 106 | osfPageUp :1004FF41 107 | osfPageDown :1004FF42 108 | osfPageRight :1004FF43 109 | osfActivate :1004FF44 110 | osfMenuBar :1004FF45 111 | osfLeft :1004FF51 112 | osfUp :1004FF52 113 | osfRight :1004FF53 114 | osfDown :1004FF54 115 | osfEndLine :1004FF57 116 | osfBeginLine :1004FF58 117 | osfEndData :1004FF59 118 | osfBeginData :1004FF5A 119 | osfPrevMenu :1004FF5B 120 | osfNextMenu :1004FF5C 121 | osfPrevField :1004FF5D 122 | osfNextField :1004FF5E 123 | osfSelect :1004FF60 124 | osfInsert :1004FF63 125 | osfUndo :1004FF65 126 | osfMenu :1004FF67 127 | osfCancel :1004FF69 128 | osfHelp :1004FF6A 129 | osfSelectAll :1004FF71 130 | osfDeselectAll :1004FF72 131 | osfReselect :1004FF73 132 | osfExtend :1004FF74 133 | osfRestore :1004FF78 134 | osfDelete :1004FFFF 135 | 136 | SunFA_Grave :1005FF00 137 | SunFA_Circum :1005FF01 138 | SunFA_Tilde :1005FF02 139 | SunF36 :1005FF10 140 | SunF37 :1005FF11 141 | SunSys_Req :1005FF60 142 | SunProps :1005FF70 143 | SunFront :1005FF71 144 | SunCopy :1005FF72 145 | SunOpen :1005FF73 146 | SunPaste :1005FF74 147 | SunCut :1005FF75 148 | 149 | SunCompose :FF20 150 | SunPageUp :FF55 151 | SunPageDown :FF56 152 | SunPrint_Screen :FF61 153 | SunUndo :FF65 154 | SunAgain :FF66 155 | SunFind :FF68 156 | SunStop :FF69 157 | SunAltGraph :FF7E 158 | 159 | WYSetup :1006FF00 160 | -------------------------------------------------------------------------------- /src/typeout.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :hemlock-internals) 4 | 5 | (defun make-unique-buffer (base-name &rest keys) 6 | (loop 7 | for i from 0 8 | for name = base-name then (format nil "~A<~D>" base-name i) 9 | for buf = (apply #'make-buffer name keys) 10 | when buf do (return buf))) 11 | 12 | (defmode "Typeout" :major-p t 13 | :documentation 14 | "Typeout is a read-only buffer for pop up displays.") 15 | 16 | (defcommand "Dismiss Typeout" (p) 17 | "Close the Typeout Buffer" "" 18 | (declare (ignore p)) 19 | (hlet ((hemlock::ask-for-new-buffer nil)) 20 | (hemlock::kill-buffer-command nil (buffer-name *current-buffer*)))) 21 | 22 | (bind-key "Dismiss Typeout" #k"q" :mode "Typeout") 23 | 24 | (defun invoke-with-pop-up-display (cont buffer-name height) 25 | (declare (ignore height)) 26 | (let ((buf (make-unique-buffer buffer-name :modes '("Typeout")))) 27 | (cond ((eq (current-window) *echo-area-window*) 28 | ;; Can't pop-up in the echo area window, so choose another. 29 | (let ((window (find-if-not #'(lambda (w) (eq w *echo-area-window*)) 30 | *window-list*))) 31 | (setf (current-window) window) 32 | (change-to-buffer buf) 33 | (with-output-to-mark (stream (buffer-point buf)) 34 | (funcall cont stream)) 35 | (goto-buffer-start) 36 | (setf (buffer-modified buf) nil 37 | (buffer-writable buf) nil) 38 | ;; Switch back to the echo window and buffer. 39 | (setf (current-window) *echo-area-window*) 40 | (change-to-buffer *echo-area-buffer*) 41 | )) 42 | (t 43 | (change-to-buffer buf) 44 | (with-output-to-mark (stream (buffer-point buf)) 45 | (funcall cont stream)) 46 | (goto-buffer-start) 47 | (setf (buffer-modified buf) nil 48 | (buffer-writable buf) nil) 49 | )))) 50 | 51 | (declaim (special *random-typeout-ml-fields* *buffer-names*)) 52 | 53 | (defvar *random-typeout-buffers* () "A list of random-typeout buffers.") 54 | 55 | (defun get-random-typeout-info (buffer-name line-buffered-p) 56 | (let* ((buffer (getstring buffer-name *buffer-names*)) 57 | (stream 58 | (cond 59 | ((not buffer) 60 | (let* ((buf (make-buffer 61 | buffer-name 62 | :modes '("Fundamental") 63 | :modeline-fields *random-typeout-ml-fields* 64 | :delete-hook 65 | (list #'(lambda (buffer) 66 | (setq *random-typeout-buffers* 67 | (delete buffer *random-typeout-buffers* 68 | :key #'car)))))) 69 | (point (buffer-point buf)) 70 | (stream (make-random-typeout-stream 71 | (copy-mark point :left-inserting)))) 72 | (setf (random-typeout-stream-more-mark stream) 73 | (copy-mark point :right-inserting)) 74 | (push (cons buf stream) *random-typeout-buffers*) 75 | stream)) 76 | ((member buffer *random-typeout-buffers* :key #'car) 77 | (delete-region (buffer-region buffer)) 78 | (let* ((pair (assoc buffer *random-typeout-buffers*)) 79 | (stream (cdr pair))) 80 | (setf *random-typeout-buffers* 81 | (cons pair (delete pair *random-typeout-buffers*))) 82 | (setf (random-typeout-stream-first-more-p stream) t) 83 | (setf (random-typeout-stream-no-prompt stream) nil) 84 | stream)) 85 | (t 86 | (error "~A is not a random typeout buffer." 87 | (buffer-name buffer)))))) 88 | (setf (slot-value stream 'line-buffered-p) 89 | line-buffered-p) 90 | stream)) 91 | -------------------------------------------------------------------------------- /src/files.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; Hemlock File manipulation functions. 11 | ;;; Written by Skef Wholey, Horribly Hacked by Rob MacLachlan. 12 | ;;; Unhacked by Gilbert Baumann. 13 | ;;; 14 | 15 | (in-package :hemlock-internals) 16 | 17 | 18 | ;;;; Utility functions. 19 | 20 | ;; FIND-CHAR-FROM-SAP was here, deleted --GB 21 | 22 | 23 | ;;; Read-File: 24 | 25 | (defun read-file (pathname mark) 26 | "Inserts the contents of the file named by Pathname at the Mark." 27 | (with-mark ((mark mark :left-inserting)) 28 | (let* ((first-line (mark-line mark)) 29 | (buffer (line-%buffer first-line))) 30 | (modifying-buffer buffer) 31 | (with-open-file (input pathname :direction :input :element-type 'character) 32 | (do ((line (read-line input nil :eof) (read-line input nil :eof))) 33 | ((eql line :eof)) 34 | (insert-string mark line) 35 | (insert-character mark #\newline)))))) 36 | 37 | 38 | ;;; Write-File: 39 | 40 | (defun write-file (region pathname &key append 41 | (keep-backup (value hemlock::keep-backup-files)) 42 | access) 43 | "Writes the characters in region to the file named by pathname. This writes 44 | region using a stream opened with :if-exists :rename-and-delete, unless 45 | either append or keep-backup is supplied. If append is supplied, this 46 | writes the file opened with :if-exists :append. If keep-backup is supplied, 47 | this writes the file opened with :if-exists :rename. This signals an error 48 | if both append and keep-backup are supplied. Access is an implementation 49 | dependent value that is suitable for setting pathname's access or protection 50 | bits." 51 | (let ((if-exists-action (cond ((and keep-backup append) 52 | (error "Cannot supply non-nil values for ~ 53 | both keep-backup and append.")) 54 | (keep-backup :rename) 55 | (append :append) 56 | (t :rename-and-delete)))) 57 | (with-open-file (file pathname :direction :output 58 | :element-type 'character 59 | :external-format :utf-8 ;fixme? 60 | :if-exists if-exists-action) 61 | (close-line) 62 | (fast-write-file region file)) 63 | (hemlock-ext:set-file-permissions pathname access))) 64 | 65 | (defun fast-write-file (region file) 66 | (let* ((start (region-start region)) 67 | (start-line (mark-line start)) 68 | (start-charpos (mark-charpos start)) 69 | (end (region-end region)) 70 | (end-line (mark-line end)) 71 | (end-charpos (mark-charpos end))) 72 | (if (eq start-line end-line) 73 | ;; just one line (fragment) 74 | (write-string (line-chars start-line) file 75 | :start start-charpos :end end-charpos) 76 | ;; multiple lines 77 | (let* ((first-length (- (line-length start-line) start-charpos)) 78 | (length (+ first-length end-charpos 1))) 79 | ;; count number of octets to be written 80 | (do ((line (line-next start-line) (line-next line))) 81 | ((eq line end-line)) 82 | (incf length (1+ (line-length line)))) 83 | ;; 84 | (write-sequence (line-chars start-line) file :start start-charpos :end (+ start-charpos first-length)) 85 | (write-char #\newline file) 86 | (let ((offset (1+ first-length))) 87 | (do ((line (line-next start-line) 88 | (line-next line))) 89 | ((eq line end-line)) 90 | (let ((end (+ offset (line-length line)))) 91 | (write-sequence (line-chars line) file :start 0 :end (- end offset)) 92 | (write-char #\newline file) 93 | (setf offset (1+ end)))) 94 | (unless (zerop end-charpos) 95 | (write-sequence (line-chars end-line) file :start 0 :end end-charpos))))))) 96 | -------------------------------------------------------------------------------- /src/bitmap-input.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :hemlock-internals) 4 | 5 | (pushnew :clx *available-backends*) 6 | 7 | ;;;; Editor input from windowing system. 8 | 9 | (defclass windowed-editor-input (editor-input) 10 | ((hunks :initarg :hunks 11 | :accessor windowed-editor-input-hunks 12 | :documentation "List of bitmap-hunks which input to this stream.")) 13 | (:documentation 14 | "Editor input from windowing system.")) 15 | 16 | (defun make-windowed-editor-input (&optional (head (make-input-event)) (tail head)) 17 | (make-instance 'windowed-editor-input 18 | :head head :tail tail)) 19 | 20 | ;;; There's actually no difference from the TTY case... 21 | ;;; ### Hmm. --GB 22 | (defmethod get-key-event ((stream windowed-editor-input) &optional ignore-abort-attempts-p) 23 | (%editor-input-method stream ignore-abort-attempts-p)) 24 | 25 | (defmethod unget-key-event (key-event (stream windowed-editor-input)) 26 | (un-event key-event stream)) 27 | 28 | (defmethod clear-editor-input ((stream windowed-editor-input)) 29 | (dispatch-events-no-hang) 30 | (hemlock-ext:without-interrupts 31 | (let* ((head (editor-input-head stream)) 32 | (next (input-event-next head))) 33 | (when next 34 | (setf (input-event-next head) nil) 35 | (shiftf (input-event-next (editor-input-tail stream)) 36 | *free-input-events* next) 37 | (setf (editor-input-tail stream) head))))) 38 | 39 | (defmethod listen-editor-input ((stream windowed-editor-input)) 40 | ;;; (loop 41 | ;;; ;; Don't service anymore events if we just got some input. 42 | ;;; (when (input-event-next (editor-input-head stream)) 43 | ;;; (return t)) 44 | ;;; ;; 45 | ;;; ;; If nothing is pending, check the queued input. 46 | ;;; (unless (hemlock-ext:serve-event 0) 47 | ;;; (return (not (null (input-event-next (editor-input-head stream))))))) 48 | (dispatch-events-no-hang) 49 | nil) 50 | 51 | (defun cleanup-for-wm-closed-display (closed-display) 52 | ;; Remove fd-handlers 53 | (hemlock-ext:disable-clx-event-handling closed-display) 54 | ;; Close file descriptor and note DEAD. 55 | (xlib:close-display closed-display) 56 | ;; 57 | ;; At this point there is not much sense to returning to Lisp 58 | ;; as the editor cannot be re-entered (there are lots of pointers 59 | ;; to the dead display around that will cause subsequent failures). 60 | ;; Maybe could switch to tty mode then (save-all-files-and-exit)? 61 | ;; For now, just assume user wanted an easy way to kill the session. 62 | (hemlock-ext:quit)) 63 | 64 | (defmethod %editor-input-method 65 | :around 66 | ((editor-input windowed-editor-input) abortp) 67 | (declare (ignore abortp)) 68 | (handler-bind 69 | ((error 70 | (lambda (condition) 71 | (when (typep condition 'stream-error) 72 | (let* ((stream (stream-error-stream condition)) 73 | (display *editor-windowed-input*) 74 | (display-stream 75 | (and display (xlib::display-input-stream display)))) 76 | (when (eq stream display-stream) 77 | (format *error-output* "~%Hemlock: Display died!~%~%") 78 | (cleanup-for-wm-closed-display display) 79 | (exit-hemlock nil)) 80 | (let ((device 81 | (device-hunk-device (window-hunk (current-window))))) 82 | (device-exit device)) 83 | (invoke-debugger condition))))) 84 | (xlib:closed-display 85 | (lambda(condition) 86 | (let ((display (xlib::closed-display-display condition))) 87 | (format *error-output* 88 | "Closed display on stream ~a~%" 89 | (xlib::display-input-stream display))) 90 | (exit-hemlock nil)))) 91 | (call-next-method))) 92 | 93 | (defmethod backend-init-raw-io ((backend (eql :clx)) display) 94 | (setf *editor-windowed-input* 95 | #+(or CMU scl) (ext:open-clx-display display) 96 | #+(or sbcl openmcl) (xlib::open-default-display display) 97 | #-(or sbcl CMU scl openmcl) (xlib:open-display "localhost")) 98 | (setf *editor-input* (make-windowed-editor-input)) 99 | (setf *real-editor-input* *editor-input*) 100 | (setup-font-family *editor-windowed-input*) 101 | *editor-windowed-input*) 102 | 103 | (defmethod %init-screen-manager ((backend-type (eql :clx)) (display t)) 104 | (init-bitmap-screen-manager display)) 105 | -------------------------------------------------------------------------------- /unused/spell/io.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package "SPELL") 4 | 5 | (defparameter default-binary-dictionary #p"HOME:spell.bin") 6 | 7 | (defconstant +descriptor-bytes+ 10 8 | "The number of bytes a descriptor takes up on disk.") 9 | 10 | ;;; going for ease of writing on this first pass. later we'll pack things 11 | ;;; together a little bit more and document it. 12 | (defun read-descriptor (stream) 13 | (let ((hash-code (read-byte stream)) 14 | (length (read-byte stream)) 15 | (low-index (read-byte stream)) 16 | (high-index (read-byte stream)) 17 | (flags (read-byte stream))) 18 | (make-descriptor :hash-code hash-code 19 | :length length 20 | :char-index (dpb high-index +whole-index-high-byte+ 21 | low-index) 22 | :flags flags))) 23 | 24 | (defun write-descriptor (descriptor stream) 25 | (write-byte (desc-hash-code descriptor) stream) 26 | (write-byte (desc-length descriptor) stream) 27 | (write-byte (ldb +whole-index-low-byte+ (desc-string-index descriptor)) 28 | stream) 29 | (write-byte (ldb +whole-index-high-byte+ (desc-string-index descriptor)) 30 | stream) 31 | (write-byte (desc-flags descriptor) stream) 32 | (values)) 33 | 34 | (defun write-dictionary (filename dictionary entry-count string-table-length) 35 | (declare (fixnum string-table-length)) 36 | (with-open-file (s filename 37 | :direction :output 38 | :element-type '(unsigned-byte 16) 39 | :if-exists :overwrite 40 | :if-does-not-exist :create) 41 | (write-byte +magic-file-id+ s) 42 | (write-byte +new-dictionary-size+ s) 43 | (write-byte entry-count s) 44 | (write-byte (ldb +whole-index-low-byte+ string-table-length) s) 45 | (write-byte (ldb +whole-index-high-byte+ string-table-length) s) 46 | (dotimes (i +new-dictionary-size+) 47 | (write-byte (aref (descriptor-table dictionary) i) s)) 48 | (dotimes (i entry-count) 49 | ;; hack, because the 0th element goes unused. see if we can 50 | ;; fix this assumption in the code elsewhere 51 | (unless (zerop i) 52 | (write-descriptor (aref (descriptors dictionary) i) s))) 53 | (with-open-file (s filename 54 | :direction :output 55 | :element-type 'base-char 56 | :if-exists :append) 57 | (write-string (string-table dictionary) 58 | s :end string-table-length)))) 59 | 60 | (defun read-dictionary (&optional (filename default-binary-dictionary)) 61 | (with-open-file (stream filename 62 | :direction :input 63 | :if-does-not-exist :error 64 | :element-type '(unsigned-byte 16)) 65 | (let* ((header (make-array 5 :element-type '(unsigned-byte 16))) 66 | (header-len (read-sequence header stream))) 67 | (unless (= header-len 5) 68 | (error "File is not a dictionary: ~S." filename)) 69 | (unless (= (aref header 0) +magic-file-id+) 70 | (error "File is not a dictionary: ~S." filename)) 71 | (let* ((dict-size (read-byte stream)) 72 | (entry-count (read-byte stream)) 73 | (string-table-length-low (read-byte stream)) 74 | (string-table-length-high (read-byte stream)) 75 | (string-table-length (dpb string-table-length-high 76 | +whole-index-high-byte+ 77 | string-table-length-low)) 78 | (word-table (make-array dict-size 79 | :element-type '(unsigned-byte 16))) 80 | (descriptors (make-array (1+ entry-count) 81 | :initial-element nil)) 82 | (string-table (make-array string-table-length 83 | :element-type 'base-char))) 84 | (read-sequence word-table stream) 85 | (dotimes (i entry-count) 86 | (setf (aref descriptors (1+ i)) (read-descriptor stream))) 87 | (with-open-file (s filename 88 | :direction :input 89 | :if-does-not-exist :error 90 | :element-type 'base-char) 91 | ;; ??? is this portable? 92 | (file-position s (file-position stream)) 93 | (read-sequence string-table s)) 94 | (make-instance 'dictionary 95 | :string-table string-table 96 | :descriptors descriptors 97 | :descriptor-table word-table))))) 98 | -------------------------------------------------------------------------------- /src/pop-up-stream.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; This file contatins the stream operations for pop-up-displays. 11 | ;;; 12 | ;;; Written by Blaine Burks. 13 | ;;; 14 | 15 | (in-package :hemlock.x11) 16 | 17 | 18 | 19 | ;;;; Line-buffered Stream Methods. 20 | 21 | ;; ###GB we want a more optimized interface 22 | 23 | (defmethod stream-write-char ((stream random-typeout-stream) char) 24 | (with-slots (line-buffered-p) stream 25 | (cond (line-buffered-p 26 | (insert-character (random-typeout-stream-mark stream) char) 27 | (when (and (char= char #\newline) 28 | (not (random-typeout-stream-no-prompt stream))) 29 | (device-random-typeout-line-more 30 | (device-hunk-device 31 | (window-hunk (random-typeout-stream-window stream))) 32 | stream 1))) 33 | (t 34 | (insert-character (random-typeout-stream-mark stream) char))))) 35 | 36 | (defmethod stream-write-string ((stream random-typeout-stream) string &optional start end) 37 | (setf start (or start 0)) 38 | (setf end (or end (length string))) 39 | (with-slots (line-buffered-p) stream 40 | (cond (line-buffered-p 41 | (insert-string (random-typeout-stream-mark stream) string start end) 42 | (unless (random-typeout-stream-no-prompt stream) 43 | (let ((count (count #\newline string))) 44 | (when count 45 | (device-random-typeout-line-more 46 | (device-hunk-device 47 | (window-hunk (random-typeout-stream-window stream))) 48 | stream count))))) 49 | (t 50 | (insert-string (random-typeout-stream-mark stream) string start end))))) 51 | 52 | (defmethod stream-finish-output ((stream random-typeout-stream)) 53 | (with-slots (line-buffered-p) stream 54 | (cond (line-buffered-p 55 | (random-typeout-redisplay (random-typeout-stream-window stream))) 56 | (t 57 | nil)))) 58 | 59 | (defmethod stream-force-output ((stream random-typeout-stream)) 60 | (stream-finish-output stream)) 61 | 62 | (defmethod stream-line-column ((stream random-typeout-stream)) 63 | (mark-charpos (random-typeout-stream-mark stream))) 64 | 65 | ;;; Tty line-buffered support. 66 | 67 | ;;; UPDATE-TTY-LINE-BUFFERED-STREAM is called when anything is written to 68 | ;;; a line-buffered-random-typeout-stream on the tty. It just makes sure 69 | ;;; hemlock doesn't choke on extra-long strings. 70 | ;;; 71 | (defun update-tty-line-buffered-stream (stream newline-count) 72 | (let ((window (random-typeout-stream-window stream))) 73 | (when (plusp newline-count) (random-typeout-redisplay window)) 74 | (loop 75 | (when (no-text-past-bottom-p window) (return)) 76 | (display-more-prompt stream) 77 | (scroll-window window (window-height window)) 78 | (random-typeout-redisplay window)))) 79 | 80 | 81 | ;;; DO-BITMAP-FULL-MORE and DO-TTY-FULL-MORE scroll through the fresh text in 82 | ;;; random typeout buffer. 83 | ;;; 84 | 85 | ;;; Tty full-buffered support. 86 | 87 | (defun do-tty-full-more (stream) 88 | (let* ((window (random-typeout-stream-window stream)) 89 | (buffer (window-buffer window))) 90 | (with-mark ((end-check (buffer-end-mark buffer))) 91 | (when (and (mark/= (buffer-start-mark buffer) end-check) 92 | (empty-line-p end-check)) 93 | (line-end (line-offset end-check -1))) 94 | (loop 95 | (when (displayed-p end-check window) 96 | (return)) 97 | (display-more-prompt stream) 98 | (scroll-window window (window-height window)))))) 99 | 100 | 101 | ;;; Proclaim this special so the compiler doesn't warn me. I hate that. 102 | ;;; 103 | (declaim (special *more-prompt-action*)) 104 | 105 | (defun display-more-prompt (stream) 106 | (unless (random-typeout-stream-no-prompt stream) 107 | (let ((window (random-typeout-stream-window stream)) 108 | (*more-prompt-action* :more)) 109 | (update-modeline-field (window-buffer window) window :more-prompt) 110 | (random-typeout-redisplay window) 111 | (wait-for-more stream) 112 | (let ((*more-prompt-action* :empty)) 113 | (update-modeline-field (window-buffer window) window :more-prompt))))) 114 | -------------------------------------------------------------------------------- /src/font.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; Written by Rob MacLachlan 11 | ;;; Modified by Bill Chiles toward Hemlock running under X. 12 | ;;; 13 | ;;; This file contains various functions that make up the user interface to 14 | ;;; fonts. 15 | ;;; 16 | 17 | (in-package :hemlock-internals) 18 | 19 | ;;; Default-font used to be in the above list, but when I cleaned up the way 20 | ;;; Hemlock compiles, a name conflict occurred because "Default Font" is a 21 | ;;; Hemlock variable. It is now exported by the export list in rompsite.lisp. 22 | 23 | (defvar *default-font-family* (make-font-family)) 24 | 25 | 26 | 27 | ;;;; Creating, Deleting, and Moving. 28 | 29 | ;;; Could do more checking here. 30 | (defun valid-font-p (font) 31 | (cond ((integerp font) 32 | (and (>= font 0) (< font font-map-size))) 33 | ((listp font) 34 | t))) 35 | 36 | (defun font-mark (line charpos font &optional (kind :right-inserting)) 37 | "Returns a font on line at charpos with font. Font marks must be permanent 38 | marks." 39 | (unless (or (eq kind :right-inserting) (eq kind :left-inserting)) 40 | (error "A Font-Mark must be :left-inserting or :right-inserting.")) 41 | (unless (valid-font-p font) 42 | (error "Invalid font: ~S" font)) 43 | (let ((new (internal-make-font-mark line charpos kind font))) 44 | (new-font-mark new line) 45 | (push new (line-marks line)) 46 | new)) 47 | 48 | (defun delete-font-mark (font-mark) 49 | "Deletes a font mark." 50 | (check-type font-mark font-mark) 51 | (let ((line (mark-line font-mark))) 52 | (when line 53 | (setf (line-marks line) (delq font-mark (line-marks line))) 54 | (nuke-font-mark font-mark line) 55 | (setf (mark-line font-mark) nil)))) 56 | 57 | (defun delete-line-font-marks (line) 58 | "Deletes all font marks on line." 59 | (dolist (m (line-marks line)) 60 | (when (fast-font-mark-p m) 61 | (delete-font-mark m)))) 62 | 63 | (defun move-font-mark (font-mark new-position) 64 | "Moves font mark font-mark to location of mark new-position." 65 | (check-type font-mark font-mark) 66 | (let ((old-line (mark-line font-mark)) 67 | (new-line (mark-line new-position))) 68 | (nuke-font-mark font-mark old-line) 69 | (move-mark font-mark new-position) 70 | (new-font-mark font-mark new-line) 71 | font-mark)) 72 | 73 | (defun nuke-font-mark (mark line) 74 | (new-font-mark mark line)) 75 | 76 | (defun new-font-mark (mark line) 77 | (declare (ignore mark)) 78 | (let ((buffer (line-%buffer line)) 79 | (number (line-number line))) 80 | (when (bufferp buffer) 81 | (dolist (w (buffer-windows buffer)) 82 | (setf (window-tick w) (1- (buffer-modified-tick buffer))) 83 | (let ((first (cdr (window-first-line w)))) 84 | (unless (or (> (line-number (dis-line-line (car first))) number) 85 | (> number 86 | (line-number 87 | (dis-line-line (car (window-last-line w)))))) 88 | (do ((dl first (cdr dl))) 89 | ((or (null dl) 90 | (eq (dis-line-line (car dl)) line)) 91 | (when dl 92 | (setf (dis-line-old-chars (car dl)) :font-change)))))))))) 93 | 94 | 95 | 96 | ;;;; Referencing and setting font ids. 97 | 98 | (defun window-font (window font) 99 | "Returns a font id for window and font." 100 | (svref (font-family-map (bitmap-hunk-font-family (window-hunk window))) font)) 101 | 102 | (defun (setf window-font) (font-object window font) 103 | "Change the font-object associated with a font-number in a window." 104 | (unless (valid-font-p font) 105 | (error "Invalid font: ~S" font)) 106 | (setf (bitmap-hunk-trashed (window-hunk window)) :font-change) 107 | (let ((family (bitmap-hunk-font-family (window-hunk window)))) 108 | (when (eq family *default-font-family*) 109 | (setq family (copy-font-family family)) 110 | (setf (font-family-map family) (copy-seq (font-family-map family))) 111 | (setf (bitmap-hunk-font-family (window-hunk window)) family)) 112 | (setf (svref (font-family-map family) font) font-object))) 113 | 114 | (defun default-font (font) 115 | "Returns the font id for font out of the default font family." 116 | (svref (font-family-map *default-font-family*) font)) 117 | 118 | (defun (setf default-font) (font-object font) 119 | "Change the font-object associated with a font-number in new windows." 120 | (unless (valid-font-p font) 121 | (error "Invalid font: ~S" font)) 122 | (dolist (w *window-list*) 123 | (when (eq (bitmap-hunk-font-family (window-hunk w)) *default-font-family*) 124 | (setf (bitmap-hunk-trashed (window-hunk w)) :font-change))) 125 | (setf (svref (font-family-map *default-font-family*) font) font-object)) 126 | -------------------------------------------------------------------------------- /src/apropos.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; Slave Apropos (as opposed to "hemlock com>mand name apropos" aka Apropos) 4 | 5 | (in-package :hemlock) 6 | 7 | 8 | 9 | (defvar *apropos-entries* nil) 10 | (defvar *apropos-entries-end* nil) 11 | ;;; 12 | 13 | (defstruct (apropos-entry 14 | (:constructor internal-make-apropos-entry 15 | (slavesym kind docstring))) 16 | slavesym 17 | kind 18 | docstring) 19 | 20 | (defun parse-apropos-entry (slot-list) 21 | (destructuring-bind (slavesym &optional (kind :unbound) docstring) 22 | slot-list 23 | (internal-make-apropos-entry 24 | slavesym 25 | kind 26 | (if (eq docstring :not-documented) nil docstring)))) 27 | 28 | ;;; This is the apropos buffer if it exists. 29 | ;;; 30 | (defvar *apropos-buffer* nil) 31 | 32 | ;;; This is the cleanup method for deleting *apropos-buffer*. 33 | ;;; 34 | (defun delete-apropos-buffers (buffer) 35 | (when (eq buffer *apropos-buffer*) 36 | (setf *apropos-buffer* nil) 37 | (setf *apropos-entries* nil))) 38 | 39 | 40 | ;;;; Commands. 41 | 42 | (defmode "Apropos" :major-p t 43 | :documentation "Apropos mode presents a list of slave symbols.") 44 | 45 | (defcommand "Apropos Quit" (p) 46 | "Kill the apropos buffer." 47 | "" 48 | (declare (ignore p)) 49 | (when *apropos-buffer* (delete-buffer-if-possible *apropos-buffer*))) 50 | 51 | (defun apropos-entry-from-mark (mark) 52 | ) 53 | 54 | (defcommand "Apropos Find Definition" (p) 55 | "" "" 56 | (declare (ignore p)) 57 | (let ((entry (apropos-entry-from-mark (current-point)))) 58 | (when entry 59 | (change-to-definition entry)))) 60 | 61 | (defcommand "Apropos Describe" (p) 62 | "" "" 63 | (declare (ignore p)) 64 | (let ((entry (apropos-entry-from-mark (current-point)))) 65 | (when entry 66 | (change-to-definition entry)))) 67 | 68 | (defun refresh-apropos (buf entries) 69 | (with-writable-buffer (buf) 70 | (delete-region (buffer-region buf)) 71 | (setf *apropos-entries-end* (length entries)) 72 | (setf *apropos-entries* (coerce entries 'vector)) 73 | (with-output-to-mark (s (buffer-point buf)) 74 | (dolist (entry entries) 75 | (apropos-write-line entry s))))) 76 | 77 | (defun make-apropos-buffer (entries) 78 | (let ((buf (or *apropos-buffer* 79 | (make-buffer "*Slave Apropos*" :modes '("Apropos"))))) 80 | (setf *apropos-buffer* buf) 81 | (refresh-apropos buf entries) 82 | (let ((fields (buffer-modeline-fields *apropos-buffer*))) 83 | (setf (cdr (last fields)) 84 | (list (or (modeline-field :apropos-cmds) 85 | (make-modeline-field 86 | :name :apropos-cmds :width 18 87 | :function 88 | #'(lambda (buffer window) 89 | (declare (ignore buffer window)) 90 | " Type ? for help."))))) 91 | (setf (buffer-modeline-fields *apropos-buffer*) fields)) 92 | (buffer-start (buffer-point buf)) 93 | (change-to-buffer buf))) 94 | 95 | (defun apropos-write-line (entry s) 96 | (format s "~A~% ~:(~A~)~:[~;: ~:*~A~]~%~%" 97 | (apropos-entry-slavesym entry) 98 | (apropos-entry-kind entry) 99 | (let ((docstring (apropos-entry-docstring entry))) 100 | (when docstring 101 | (first-line-of-string docstring))))) 102 | 103 | (defun first-line-of-string (str) 104 | (with-input-from-string (s str) (read-line s nil ""))) 105 | 106 | (defcommand "Apropos Help" (p) 107 | "Show this help." 108 | "Show this help." 109 | (declare (ignore p)) 110 | (describe-mode-command nil "Apropos")) 111 | 112 | (defcommand "Slave Apropos Ignoring Point" 113 | (p &optional (str 114 | (hemlock-interface::prompt-for-string 115 | :prompt "Apropos string: "))) 116 | "" "" 117 | (declare (ignore p)) 118 | (slave-apropos str)) 119 | 120 | (defcommand "Slave Apropos" (p) 121 | "" "" 122 | (declare (ignore p)) 123 | (let ((default (hemlock::symbol-string-at-point))) 124 | ;; Fixme: MARK-SYMBOL isn't very good, meaning that often we 125 | ;; will get random forms rather than a symbol. Let's at least 126 | ;; catch the case where the result is more than a line long, 127 | ;; and give up. 128 | (when (find #\newline default) 129 | (setf default nil)) 130 | (slave-apropos 131 | (hemlock-interface::prompt-for-string 132 | :prompt "Apropos string: " 133 | :default default)))) 134 | 135 | (defun slave-apropos (str) 136 | (hemlock::eval-in-slave `(%apropos ',str))) 137 | 138 | (defun %apropos (str) 139 | (let ((data 140 | (mapcar (lambda (sym) 141 | (cons (make-slave-symbol sym) 142 | (conium:describe-symbol-for-emacs sym))) 143 | (apropos-list str)))) 144 | (hemlock::eval-in-master `(%apropos-results ',data ',str)))) 145 | 146 | (defun %apropos-results (data str) 147 | (let ((entries (mapcar #'parse-apropos-entry data))) 148 | (cond 149 | ((null data) 150 | (message "No apropos results for: ~A" str)) 151 | (t 152 | (make-apropos-buffer entries))))) 153 | -------------------------------------------------------------------------------- /src/bit-stuff.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :hemlock.x11) 4 | 5 | (defclass bitmap-device (device) 6 | ((display :initarg :display 7 | :initform nil 8 | :accessor bitmap-device-display 9 | :documentation "CLX display object."))) 10 | 11 | (defun make-bitmap-device (&rest initargs) 12 | (apply #'make-instance 'bitmap-device initargs)) 13 | 14 | ;;; Bitmap hunks. 15 | ;;; 16 | ;;; The lock field is no longer used. If events could be handled while we 17 | ;;; were in the middle of something with the hunk, then this could be set 18 | ;;; for exclusion purposes. 19 | ;;; 20 | (defclass bitmap-hunk (device-hunk) 21 | ((width 22 | :initarg :width 23 | :initform nil 24 | :accessor bitmap-hunk-width 25 | :documentation "Pixel width.") 26 | (char-height 27 | :initarg :char-height 28 | :initform nil 29 | :accessor bitmap-hunk-char-height 30 | :documentation "Height of text body in characters.") 31 | (char-width 32 | :initarg :char-width 33 | :initform nil 34 | :accessor bitmap-hunk-char-width 35 | :documentation "Width in characters.") 36 | (start 37 | :initarg :start 38 | :initform nil 39 | :accessor bitmap-hunk-start 40 | :documentation "Head of dis-line list (no dummy).") 41 | (end 42 | :initarg :end 43 | :initform nil 44 | :accessor bitmap-hunk-end 45 | :documentation "Exclusive end, i.e. nil if nil-terminated.") 46 | (modeline-dis-line 47 | :initarg :modeline-dis-line 48 | :initform nil 49 | :accessor bitmap-hunk-modeline-dis-line 50 | :documentation "Dis-line for modeline, or NIL if none.") 51 | (modeline-pos 52 | :initarg :modeline-pos 53 | :initform nil 54 | :accessor bitmap-hunk-modeline-pos 55 | :documentation "Position of modeline in pixels.") 56 | (lock 57 | :initarg :lock 58 | :initform t 59 | :accessor bitmap-hunk-lock 60 | :documentation "Something going on, set trashed if we're changed.") 61 | (trashed 62 | :initarg :trashed 63 | :initform nil 64 | :accessor bitmap-hunk-trashed 65 | :documentation "Something bad happened, recompute image.") 66 | (font-family 67 | :initarg :font-family 68 | :initform nil 69 | :accessor bitmap-hunk-font-family 70 | :documentation "Font-family used in this window.") 71 | (input-handler 72 | :initarg :input-handler 73 | :initform nil 74 | :accessor bitmap-hunk-input-handler 75 | :documentation "Gets hunk, char, x, y when char read.") 76 | (changed-handler 77 | :initarg :changed-handler 78 | :initform nil 79 | :accessor bitmap-hunk-changed-handler 80 | :documentation "Gets hunk when size changed.") 81 | (thumb-bar-p 82 | :initarg :thumb-bar-p 83 | :initform nil 84 | :accessor bitmap-hunk-thumb-bar-p 85 | :documentation "True if we draw a thumb bar in the top border.") 86 | (window-group 87 | :initarg :window-group 88 | :initform nil 89 | :accessor bitmap-hunk-window-group 90 | :documentation "The window-group to which this hunk belongs."))) 91 | 92 | (defclass x11-hunk (bitmap-hunk) 93 | ((xwindow 94 | :initarg :xwindow 95 | :initform nil 96 | :accessor bitmap-hunk-xwindow 97 | :documentation "X window for this hunk.") 98 | (gcontext 99 | :initarg :gcontext 100 | :initform nil 101 | :accessor bitmap-hunk-gcontext 102 | :documentation "X gcontext for xwindow."))) 103 | 104 | (defun bitmap-hunk-height (hunk) 105 | (hi::device-hunk-height hunk)) 106 | 107 | (defun (setf bitmap-hunk-height) (value hunk) 108 | (setf (hi::device-hunk-height hunk) value)) 109 | 110 | (defun bitmap-hunk-window (hunk) 111 | (hi::device-hunk-window hunk)) 112 | 113 | (defun (setf bitmap-hunk-window) (value hunk) 114 | (setf (hi::device-hunk-window hunk) value)) 115 | 116 | (defun bitmap-hunk-previous (hunk) 117 | (hi::device-hunk-previous hunk)) 118 | 119 | (defun (setf bitmap-hunk-previous) (value hunk) 120 | (setf (hi::device-hunk-previous hunk) value)) 121 | 122 | (defun bitmap-hunk-next (hunk) 123 | (hi::device-hunk-next hunk)) 124 | 125 | (defun (setf bitmap-hunk-next) (value hunk) 126 | (setf (hi::device-hunk-next hunk) value)) 127 | 128 | (defun bitmap-hunk-device (hunk) 129 | (hi::device-hunk-device hunk)) 130 | 131 | (defun (setf bitmap-hunk-device) (value hunk) 132 | (setf (hi::device-hunk-device hunk) value)) 133 | 134 | (defun bitmap-hunk-position (hunk) 135 | (hi::device-hunk-position hunk)) 136 | 137 | (defun (setf bitmap-hunk-position) (value hunk) 138 | (setf (hi::device-hunk-position hunk) value)) 139 | 140 | (defun make-bitmap-hunk (&rest initargs) 141 | (apply #'make-instance 'x11-hunk initargs)) 142 | 143 | #|| 144 | ;;;; What we want now is: 145 | 146 | (defclass bitmap-hunk (device-hunk) 147 | ;; a hunk for a generic bitmap device 148 | ) 149 | 150 | (defclass x11-hunk (bitmap-hunk) 151 | ;; XLIB stufff 152 | ) 153 | 154 | (defclass clim-hunk (bitmap-hunk) 155 | ;; A CLIM hunk 156 | ) 157 | 158 | ;; and having hunk-replace-line etc. (essentially hunk-draw.lisp) 159 | ;; being methods on these. 160 | 161 | ||# 162 | 163 | (defgeneric hunk-put-string* (hunk x y font-family font string start end)) 164 | (defgeneric old-hunk-replace-line (hunk dl &optional position)) 165 | (defgeneric hunk-clear-lines (hunk start count)) 166 | (defgeneric hunk-copy-lines (hunk src dst count)) 167 | (defgeneric hunk-replace-modeline (hunk)) 168 | -------------------------------------------------------------------------------- /src/bitmap-pop-up-stream.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :hemlock.x11) 4 | 5 | ;;; Bitmap line-buffered support. 6 | 7 | ;;; UPDATE-BITMAP-LINE-BUFFERED-STREAM is called when anything is written to 8 | ;;; a line-buffered-random-typeout-stream on the bitmap. It does a lot of 9 | ;;; checking to make sure that strings of characters longer than the width of 10 | ;;; the window don't screw us. The code is a little wierd, so a brief 11 | ;;; explanation is below. 12 | ;;; 13 | ;;; The more-mark is how we tell when we will next need to more. Each time 14 | ;;; we do a more-prompt, we point the mark at the last visible character in 15 | ;;; the random typeout window. That way, when the mark is no longer 16 | ;;; DISPLAYED-P, we know it's time to do another more prompt. 17 | ;;; 18 | ;;; If the buffer-end-mark is DISPLAYED-P, then we return, only redisplaying 19 | ;;; if there was at least one newline in the last batch of output. If we 20 | ;;; haven't done a more prompt yet (indicated by a value of T for 21 | ;;; first-more-p), then since we know the end of the buffer isn't visible, we 22 | ;;; need to do a more-prompt. If neither of the first two tests returns T, 23 | ;;; then we can only need to do a more-prompt if our more-mark has scrolled 24 | ;;; off the top of the screen. If it hasn't, everything is peechy-keen, so 25 | ;;; we scroll the screen one line and redisplay. 26 | ;;; 27 | (defmethod device-random-typeout-line-more ((device bitmap-device) stream newline-count) 28 | (let* ((window (random-typeout-stream-window stream)) 29 | (count 0)) 30 | (when (plusp newline-count) (random-typeout-redisplay window)) 31 | (loop 32 | (cond ((no-text-past-bottom-p window) 33 | (return)) 34 | ((or (random-typeout-stream-first-more-p stream) 35 | (not (displayed-p (random-typeout-stream-more-mark stream) 36 | window))) 37 | (do-bitmap-more-prompt stream) 38 | (return)) 39 | (t 40 | (scroll-window window 1) 41 | (random-typeout-redisplay window))) 42 | (when (= (incf count) newline-count) (return))))) 43 | 44 | ;;; NO-TEXT-PAST-BOTTOM-P determines whether there is text left to be displayed 45 | ;;; in the random-typeout window. It does this by first making sure there is a 46 | ;;; line past the WINDOW-DISPLAY-END of the window. If there is, this line 47 | ;;; must be empty, and BUFFER-END-MARK must be on this line. The final test is 48 | ;;; that the window-end is displayed within the window. If it is not, then the 49 | ;;; last line wraps past the end of the window, and there is text past the 50 | ;;; bottom. 51 | ;;; 52 | ;;; Win-end is bound after the call to DISPLAYED-P because it updates the 53 | ;;; window's image moving WINDOW-DISPLAY-END. We want this updated value for 54 | ;;; the display end. 55 | ;;; 56 | (defun no-text-past-bottom-p (window) 57 | (let* ((window-end (window-display-end window)) 58 | (window-end-displayed-p (displayed-p window-end window))) 59 | (with-mark ((win-end window-end)) 60 | (let ((one-after-end (line-offset win-end 1))) 61 | (if one-after-end 62 | (and (empty-line-p win-end) 63 | (same-line-p win-end (buffer-end-mark (window-buffer window))) 64 | window-end-displayed-p) 65 | window-end-displayed-p))))) 66 | 67 | (defun reset-more-mark (stream) 68 | (let* ((window (random-typeout-stream-window stream)) 69 | (more-mark (random-typeout-stream-more-mark stream)) 70 | (end (window-display-end window))) 71 | (move-mark more-mark end) 72 | (unless (displayed-p end window) (character-offset more-mark -1)))) 73 | 74 | ;;; DO-BITMAP-MORE-PROMPT is the function that atually displays the more prompt 75 | ;;; and reacts to it. Things are pretty clear. The loop is neccessary because 76 | ;;; someone could screw us by never outputting newlines. Improbable, but 77 | ;;; possible. 78 | ;;; 79 | (defun do-bitmap-more-prompt (stream) 80 | (let* ((window (random-typeout-stream-window stream)) 81 | (height (window-height window))) 82 | (setf (random-typeout-stream-first-more-p stream) nil) 83 | (reset-more-mark stream) 84 | (loop 85 | (when (no-text-past-bottom-p window) (return)) 86 | (display-more-prompt stream) 87 | (do ((i 0 (1+ i))) 88 | ((or (= i height) (no-text-past-bottom-p window))) 89 | (scroll-window window 1) 90 | (random-typeout-redisplay window))) 91 | (unless (displayed-p (random-typeout-stream-more-mark stream) window) 92 | (reset-more-mark stream)))) 93 | 94 | 95 | ;;; DO-BITMAP-FULL-MORE and DO-TTY-FULL-MORE scroll through the fresh text in 96 | ;;; random typeout buffer. The bitmap function does some checking so that 97 | ;;; we don't overshoot the end of the buffer. 98 | ;;; 99 | (defmethod device-random-typeout-full-more ((device bitmap-device) stream) 100 | (let* ((window (random-typeout-stream-window stream)) 101 | (buffer (window-buffer window)) 102 | (height (window-height window))) 103 | (with-mark ((end-check (buffer-end-mark buffer))) 104 | (when (and (mark/= (buffer-start-mark buffer) end-check) 105 | (empty-line-p end-check)) 106 | (line-end (line-offset end-check -1))) 107 | (loop 108 | (when (displayed-p end-check window) 109 | (return)) 110 | (display-more-prompt stream) 111 | (do ((i 0 (1+ i))) 112 | ((or (= i height) (displayed-p end-check window))) 113 | (scroll-window window 1) 114 | (random-typeout-redisplay window)))))) 115 | -------------------------------------------------------------------------------- /unused/elisp/read-table.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package "ELISP-INTERNALS") 4 | 5 | (defvar *elisp-readtable* (copy-readtable)) 6 | 7 | (cl:defun read-vector (stream char) 8 | (when (char= char #\[) 9 | (coerce (read-delimited-list #\] stream t) 'vector))) 10 | 11 | (cl:defun read-character (stream char) 12 | (if (char= char #\?) 13 | (read-string-char stream :event) 14 | (values))) 15 | 16 | ;;; Note to self. Implement this, head hurts, another day. 17 | ;;; Is hopefully mostly done... 18 | (cl:defun emit-character (charspec context) 19 | (cl:case context 20 | (:character 21 | (cl:let ((char (char-code (car (last charspec))))) 22 | (if (member :control charspec) 23 | (setf char (mod char 32))) 24 | (if (member :meta charspec) 25 | (setf char (+ 128 char))) 26 | (code-char char) 27 | )) 28 | (:event 29 | (cl:let ((string (with-output-to-string (s) 30 | (write-char #\" s) 31 | (loop for entity in charspec 32 | do (case entity 33 | (:control 34 | (write-char #\C s) 35 | (write-char #\- s)) 36 | (:meta 37 | (write-char #\M s) 38 | (write-char #\- s)) 39 | (t (write-char entity s)))) 40 | (write-char #\" s)))) 41 | (with-input-from-string (hackstring string) 42 | (eval (hemlock-ext::parse-key-fun hackstring #\k 2)))) 43 | ))) 44 | 45 | (defun read-octal (stream acc level) 46 | (cl:if (= level 3) 47 | (code-char acc) 48 | (let ((char (cl:read-char stream nil stream t))) 49 | (case char 50 | ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) 51 | (if (and (char= char #\0) (zerop acc)) 52 | (code-char 0) 53 | (let ((value (position char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) :test #'char=))) 54 | (cl:if (< (+ value (* 8 acc)) 256) 55 | (read-octal stream (+ value (* 8 acc)) (1+ level)) 56 | (progn (unread-char char stream) (code-char acc)))))) 57 | (t (if (zerop acc) 58 | char 59 | (progn 60 | (unread-char char stream) 61 | (code-char acc)))))))) 62 | 63 | (cl:defun read-string-char (stream context) 64 | (cl:let ((char (cl:read-char stream nil stream t))) 65 | (if (char= char #\\) 66 | (cl:let ((next (cl:read-char stream nil stream t))) 67 | (case next 68 | (#\a (emit-character '(:control #\g) context)) 69 | (#\n (emit-character '(:control #\j) context)) 70 | (#\b (emit-character '(:control #\h) context)) 71 | (#\r (emit-character '(:control #\m) context)) 72 | (#\v (emit-character '(:control #\k) context)) 73 | (#\f (emit-character '(:control #\l) context)) 74 | (#\t (emit-character '(:control #\i) context)) 75 | (#\e (emit-character '(:control #\[) context)) 76 | (#\\ #\\) 77 | (#\" #\") 78 | (#\d (emit-character '(#\Rubout) context)) 79 | ((#\C #\M) 80 | (unread-char next stream) 81 | (emit-character 82 | (do ((char (read-char stream) (read-char stream)) 83 | (expect-dash nil (not expect-dash)) 84 | (terminate nil) 85 | (collection nil)) 86 | ((or (and expect-dash (not (char= char #\-))) 87 | terminate) 88 | (unread-char char stream) 89 | (nreverse collection)) 90 | (cond (expect-dash) 91 | ((char= char #\M) 92 | (setf collection (cons :meta collection))) 93 | ((char= char #\C) 94 | (setf collection (cons :control collection))) 95 | (t (setf terminate t) 96 | (setf collection (cons char collection))))) 97 | context)) 98 | ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) 99 | (read-octal stream 0 0) 100 | ))) 101 | char))) 102 | 103 | (cl:defun read-string (stream char) 104 | (if (char= char #\") 105 | (with-output-to-string (s) 106 | (loop for char = (read-string-char stream :character) 107 | if (char= char #\") return s 108 | else do (cl:write-char char s))))) 109 | 110 | (cl:defun sharp-ampersand (stream ignore arg) 111 | (declare (ignore ignore arg)) 112 | (let ((length (cl:read stream t stream t))) 113 | (if (not (integerp length)) 114 | (values) 115 | (let ((string (read stream stream stream t)) 116 | (rv (make-array (list length) :element-type 'bit :initial-element 0))) 117 | (if (stringp string) 118 | (progn 119 | (loop for ix from 0 to (1- length) 120 | do (multiple-value-bind (char shift) (truncate ix 8) 121 | (let ((val (char-code (char string char)))) 122 | (unless (zerop (logand val (ash 1 shift))) 123 | (setf (aref rv ix) 1))))) 124 | rv) 125 | (values)))))) 126 | 127 | (set-macro-character #\[ 'read-vector nil *elisp-readtable*) 128 | (set-macro-character #\] (get-macro-character #\)) nil *elisp-readtable*) 129 | (set-macro-character #\? 'read-character nil *elisp-readtable*) 130 | (set-macro-character #\" 'read-string nil *elisp-readtable*) 131 | (set-dispatch-macro-character #\# #\& #'sharp-ampersand *elisp-readtable*) 132 | (set-syntax-from-char #\[ #\() 133 | (set-syntax-from-char #\] #\)) 134 | -------------------------------------------------------------------------------- /src/line.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | (in-package :hemlock-internals) 8 | 9 | ;;; 10 | ;;; ********************************************************************** 11 | ;;; 12 | ;;; This file contains definitions for the Line structure, and some 13 | ;;; functions and macros to manipulate them. 14 | ;;; 15 | 16 | (setf (documentation 'linep 'function) 17 | "Returns true if its argument is a Hemlock line object, Nil otherwise.") 18 | (setf (documentation 'line-previous 'function) 19 | "Return the Hemlock line that precedes this one, or Nil if there is no 20 | previous line.") 21 | (setf (documentation 'line-next 'function) 22 | "Return the Hemlock line that follows this one, or Nil if there is no 23 | next line.") 24 | (setf (documentation 'line-plist 'function) 25 | "Return a line's property list. This may be manipulated with Setf and Getf.") 26 | 27 | 28 | ;;;; The line object: 29 | 30 | (defclass line () 31 | ((chars 32 | :initform "" 33 | :initarg :chars ; Hide the fact that the slot isn't really called CHARS. 34 | :accessor line-chars 35 | :documentation "Something that represents the contents of the line. This is 36 | guaranteed to change (as compared by EQL) whenver the contents of the 37 | line changes, but might at arbitarary other times. There are 38 | currently about two different cases: 39 | 40 | Normal: 41 | A simple string holding the contents of the line. 42 | 43 | A cached line: 44 | The line is eq to Open-Line, and the actual contents are in the 45 | line cache. The %Chars may be either the original contents or a 46 | negative fixnum.") 47 | (previous 48 | :initform nil 49 | :initarg :previous 50 | :accessor line-previous 51 | :documentation "Pointer to the previous line in the doubly linked list of line instances.") 52 | (next 53 | :initform nil 54 | :initarg :next 55 | :accessor line-next 56 | :documentation "Pointer to the next line in the doubly linked list of line instances.") 57 | (marks 58 | :initform nil 59 | :initarg :marks 60 | :accessor line-marks 61 | :documentation "A list of all the permanent marks pointing into this line.") 62 | (%buffer 63 | :initform nil 64 | :initarg :%buffer 65 | :accessor line-%buffer 66 | :documentation "The buffer to which this line belongs, or a *disembodied-buffer-count* if the line is not in any buffer.") 67 | (number 68 | :initform 0 69 | :initarg :number 70 | :accessor line-number 71 | :documentation "A non-negative integer (fixnum) that represents the ordering of lines 72 | within continguous range of lines (a buffer or disembuffered region). 73 | The number of the Line-Next is guaranteed to be strictly greater than 74 | our number, and the Line-Previous is guaranteed to be strictly less.") 75 | (plist 76 | :initform nil 77 | :initarg :plist 78 | :accessor line-plist 79 | :documentation "The line property list, used by user code to annotate the text.") 80 | (tag 81 | :accessor %line-tag 82 | :initform nil 83 | :documentation "Line tag, which records information available only if all 84 | preceding lines have been analyzed yet.")) 85 | (:documentation 86 | "A Hemlock line object. See Hemlock design document for details.")) 87 | 88 | (defun make-line (&rest initargs) 89 | (apply #'make-instance 'line initargs)) 90 | 91 | (defmethod linep ((line line)) 92 | t) 93 | 94 | (defmethod linep ((object t)) 95 | nil) 96 | 97 | (defstruct (syntax-info 98 | (:conc-name sy-) 99 | (:constructor make-syntax-info 100 | (signature from-state to-state font-marks))) 101 | (signature :bogus-signature) 102 | from-state 103 | to-state 104 | font-marks) 105 | 106 | (defstruct tag 107 | (ticks -1) 108 | (line-number 1 :type (integer 1)) 109 | (syntax-info nil :type (or null syntax-info)) 110 | (package (symbol-name :cl-user) :type (or null string))) 111 | 112 | 113 | ;;; Line-Signature -- Public 114 | ;;; 115 | ;;; We can just return the Line-Chars. 116 | ;;; 117 | (declaim (inline line-signature)) 118 | (defun line-signature (line) 119 | "This function returns an object which serves as a signature for a line's 120 | contents. It is guaranteed that any modification of text on the line will 121 | result in the signature changing so that it is not EQL to any previous value. 122 | Note that the signature may change even when the text hasn't been modified, but 123 | this probably won't happen often." 124 | (line-chars line)) 125 | 126 | 127 | (defun %copy-line (line &key previous number %buffer) 128 | (make-line :chars (line-chars line) 129 | :previous previous 130 | :number number 131 | :%buffer %buffer)) 132 | 133 | 134 | (defmacro line-length* (line) 135 | "Returns the number of characters on the line, but it's a macro!" 136 | `(cond ((eq ,line open-line) 137 | (+ left-open-pos (- line-cache-length right-open-pos))) 138 | (t 139 | (length (the simple-string (line-chars ,line)))))) 140 | 141 | ;; $Log: line.lisp,v $ 142 | ;; Revision 1.2 2004-12-15 12:16:45 crhodes 143 | ;; Make clim-hemlock basically work on sbcl -- mostly build fixes from Hannu 144 | ;; Koivisto. 145 | ;; 146 | ;; * don't declaim or declare stuff in CL special; 147 | ;; * classes come before methods specializing on them; 148 | ;; * clim-sys: not mp: 149 | ;; 150 | ;; Revision 1.1 2004/07/09 15:00:36 gbaumann 151 | ;; Let us see if this works. 152 | ;; 153 | -------------------------------------------------------------------------------- /src/slave-list.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; This file contains slave-list-related code. 11 | ;;; 12 | 13 | (in-package :hemlock) 14 | 15 | 16 | 17 | ;;;; Representation of existing slaves. 18 | 19 | (defvar *slave-list-items* nil) 20 | (defvar *slave-list-items-end* nil) 21 | ;;; 22 | 23 | (defstruct slave-list-item 24 | (marked nil) 25 | name 26 | info) 27 | 28 | 29 | ;;; This is the slave-list buffer if it exists. 30 | ;;; 31 | (defvar *slave-list-buffer* nil) 32 | 33 | ;;; This is the cleanup method for deleting *slave-list-buffer*. 34 | ;;; 35 | (defun delete-slave-list-buffers (buffer) 36 | (when (eq buffer *slave-list-buffer*) 37 | (setf *slave-list-buffer* nil) 38 | (setf *slave-list-items* nil))) 39 | 40 | 41 | ;;;; Commands. 42 | 43 | (defmode "Slave-List" :major-p t 44 | :documentation 45 | "List of slaves") 46 | 47 | (defcommand "Mark Slave" (p) 48 | "" "" 49 | (declare (ignore p)) 50 | (let* ((point (current-point)) 51 | (item-at-point (array-element-from-mark point *slave-list-items*))) 52 | (with-writable-buffer (*slave-list-buffer*) 53 | (setf (slave-list-item-marked item-at-point) t) 54 | (with-mark ((point point)) 55 | (setf (next-character (line-start point)) #\*)) 56 | (line-offset point 1)))) 57 | 58 | (defcommand "Unmark Slave" (p) 59 | "" "" 60 | (declare (ignore p)) 61 | (with-writable-buffer (*slave-list-buffer*) 62 | (setf (slave-list-item-marked 63 | (array-element-from-mark (current-point) *slave-list-items*)) 64 | nil) 65 | (with-mark ((point (current-point))) 66 | (setf (next-character (line-start point)) #\space)) 67 | (line-offset (current-point) 1))) 68 | 69 | (defcommand "Quit Slave List" (p) 70 | "" "" 71 | (declare (ignore p)) 72 | (when *slave-list-buffer* (delete-buffer-if-possible *slave-list-buffer*))) 73 | 74 | (defcommand "Goto Slave" (p) 75 | "" "" 76 | (let ((info (slave-list-item-info 77 | (array-element-from-mark (current-point) *slave-list-items*)))) 78 | (change-to-buffer 79 | (or (server-info-slave-buffer info) 80 | (editor-error "Slave has no buffer"))) 81 | (unless (or p (not (prompt-for-y-or-n :prompt "Set as current slave? " 82 | :default t 83 | :must-exist t 84 | :default-string "Y"))) 85 | (setf (variable-value 'current-eval-server :global) info)))) 86 | 87 | (defcommand "Activate Slave" (p) 88 | "" "" 89 | (declare (ignore p)) 90 | (setf (variable-value 'current-eval-server :global) 91 | (slave-list-item-info 92 | (array-element-from-mark (current-point) *slave-list-items*))) 93 | (refresh-slave-list *slave-list-buffer*)) 94 | 95 | (defun list-slave-items () 96 | (hi::map-string-table 'list 97 | (lambda (info) 98 | (make-slave-list-item 99 | :name (server-info-name info) 100 | :marked nil 101 | :info info)) 102 | *server-names*)) 103 | 104 | (defun refresh-slave-list (buf) 105 | (with-writable-buffer (buf) 106 | (delete-region (buffer-region buf)) 107 | (let ((items (coerce (list-slave-items) 'vector))) 108 | (setf *slave-list-items-end* (length items)) 109 | (setf *slave-list-items* items) 110 | (with-output-to-mark (s (buffer-point buf)) 111 | (iter:iter (iter:for c in-vector items) 112 | (slave-list-write-line c s))) 113 | (buffer-start (current-point))))) 114 | 115 | (defcommand "List Slaves" (p) 116 | "" "" 117 | (declare (ignore p)) 118 | (let ((buf (or *slave-list-buffer* 119 | (make-buffer "Slave-List" :modes '("Slave-List") 120 | :delete-hook (list #'delete-slave-list-buffers))))) 121 | (unless *slave-list-buffer* 122 | (setf *slave-list-buffer* buf) 123 | (refresh-slave-list buf) 124 | (let ((fields (buffer-modeline-fields *slave-list-buffer*))) 125 | (setf (cdr (last fields)) 126 | (list (or (modeline-field :slave-list-cmds) 127 | (make-modeline-field 128 | :name :slave-list-cmds :width 18 129 | :function 130 | #'(lambda (buffer window) 131 | (declare (ignore buffer window)) 132 | " Type ? for help."))))) 133 | (setf (buffer-modeline-fields *slave-list-buffer*) fields)) 134 | (buffer-start (buffer-point buf))) 135 | (change-to-buffer buf))) 136 | 137 | (defcommand "Refresh Slave List" (p) 138 | "" "" 139 | (declare (ignore p)) 140 | (when *slave-list-buffer* 141 | (refresh-slave-list *slave-list-buffer*))) 142 | 143 | (defun slave-list-write-line (item s) 144 | (let ((info (slave-list-item-info item))) 145 | (format s " ~:[ ~;(current)~] ~A~30T~A ~A~%" 146 | (eq info (value current-eval-server)) 147 | (slave-list-item-name item) 148 | (server-info-implementation-type info) 149 | (server-info-implementation-version info)))) 150 | 151 | (defcommand "Slave-List Help" (p) 152 | "Show this help." 153 | "Show this help." 154 | (declare (ignore p)) 155 | (describe-mode-command nil "Slave-List")) 156 | 157 | (bind-key "Mark Slave" #k"m" :mode "Slave-List") 158 | (bind-key "Unmark Slave" #k"u" :mode "Slave-List") 159 | (bind-key "Quit Slave List" #k"q" :mode "Slave-List") 160 | (bind-key "Goto Slave" #k"space" :mode "Slave-List") 161 | (bind-key "Activate Slave" #k"return" :mode "Slave-List") 162 | (bind-key "Refresh Slave List" #k"g" :mode "Slave-List") 163 | (bind-key "Next Line" #k"n" :mode "Slave-List") 164 | (bind-key "Previous Line" #k"p" :mode "Slave-List") 165 | (bind-key "Slave-List Help" #k"?" :mode "Slave-List") 166 | 167 | -------------------------------------------------------------------------------- /src/bitmap-rompsite.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :hi) 4 | 5 | (eval-when (:compile-toplevel :load-toplevel :execute) 6 | (defvar group-interesting-xevents 7 | '(:structure-notify))) 8 | 9 | (defvar group-interesting-xevents-mask 10 | (apply #'xlib:make-event-mask group-interesting-xevents)) 11 | 12 | (eval-when (:compile-toplevel :load-toplevel :execute) 13 | (defvar child-interesting-xevents 14 | '(:key-press :button-press :button-release :structure-notify :exposure 15 | :enter-window :leave-window))) 16 | 17 | (defvar child-interesting-xevents-mask 18 | (apply #'xlib:make-event-mask child-interesting-xevents)) 19 | 20 | (eval-when (:compile-toplevel :load-toplevel :execute) 21 | (defvar random-typeout-xevents 22 | '(:key-press :button-press :button-release :enter-window :leave-window 23 | :exposure))) 24 | 25 | (defvar random-typeout-xevents-mask 26 | (apply #'xlib:make-event-mask random-typeout-xevents)) 27 | 28 | (declaim (special hemlock::*open-paren-highlight-font* 29 | hemlock::*active-region-highlight-font*)) 30 | 31 | (defparameter lisp-fonts-pathnames '("fonts/")) 32 | 33 | ;;; SETUP-FONT-FAMILY sets *default-font-family*, opening the three font names 34 | ;;; passed in. The font family structure is filled in from the first argument. 35 | ;;; Actually, this ignores default-highlight-font and default-open-paren-font 36 | ;;; in lieu of "Active Region Highlighting Font" and "Open Paren Highlighting 37 | ;;; Font" when these are defined. 38 | ;;; 39 | (defun setup-font-family (display) 40 | (let* ((font-family (make-font-family :map (make-array font-map-size 41 | :initial-element 0) 42 | :cursor-x-offset 0 43 | :cursor-y-offset 0)) 44 | (font-family-map (font-family-map font-family))) 45 | (declare (simple-vector font-family-map)) 46 | (setf *default-font-family* font-family) 47 | (let ((font (xlib:open-font display (variable-value 'hemlock::default-font)))) 48 | (unless font 49 | (error "Cannot open font -- ~S" (variable-value 'hemlock::default-font))) 50 | (fill font-family-map font) 51 | (let ((width (xlib:max-char-width font))) 52 | (setf (font-family-width font-family) width) 53 | (setf (font-family-cursor-width font-family) width)) 54 | (let* ((baseline (xlib:font-ascent font)) 55 | (height (+ baseline (xlib:font-descent font)))) 56 | (setf (font-family-height font-family) height) 57 | (setf (font-family-cursor-height font-family) height) 58 | (setf (font-family-baseline font-family) baseline))) 59 | (setup-one-font display 60 | (variable-value 'hemlock::open-paren-highlighting-font) 61 | font-family-map 62 | hemlock::*open-paren-highlight-font*) 63 | (setup-one-font display 64 | (variable-value 'hemlock::active-region-highlighting-font) 65 | font-family-map 66 | hemlock::*active-region-highlight-font*) 67 | ;; GB 68 | (setup-one-font display 69 | "-*-lucidatypewriter-medium-r-*-*-*-120-*-*-*-*-iso8859-1" 70 | font-family-map 71 | 7))) 72 | 73 | ;;; SETUP-ONE-FONT tries to open font-name for display, storing the result in 74 | ;;; font-family-map at index. XLIB:OPEN-FONT will return font stuff regardless 75 | ;;; if the request is valid or not, so we finish the output to get synch'ed 76 | ;;; with the server which will cause any errors to get signaled. At this 77 | ;;; level, we want to deal with this error here returning nil if the font 78 | ;;; couldn't be opened. 79 | ;;; 80 | (defun setup-one-font (display font-name font-family-map index) 81 | (handler-case (let ((font (xlib:open-font display (namestring font-name)))) 82 | (xlib:display-finish-output display) 83 | (setf (svref font-family-map index) font)) 84 | (xlib:name-error () 85 | (warn "Cannot open font -- ~S" font-name) 86 | nil))) 87 | 88 | ;;; INIT-RAW-IO -- Internal 89 | ;;; 90 | ;;; This function should be called whenever the editor is entered in a new 91 | ;;; lisp. It sets up process specific data structures. 92 | ;;; 93 | #+nilamb-duplicate(defun init-raw-io (display) 94 | #-clx (declare (ignore display)) 95 | (setf *editor-windowed-input* nil) 96 | (cond #+clx 97 | (display 98 | (setf *editor-windowed-input* 99 | #+(or CMU scl) (ext:open-clx-display display) 100 | #+(or sbcl openmcl) (xlib::open-default-display #+nil display) 101 | #-(or sbcl CMU scl openmcl) (xlib:open-display "localhost")) 102 | (setf *editor-input* (make-windowed-editor-input)) 103 | (setup-font-family *editor-windowed-input*)) 104 | #+nilamb 105 | (t ;; The editor's file descriptor is Unix standard input (0). 106 | ;; We don't need to affect system:*file-input-handlers* here 107 | ;; because the init and exit methods for tty redisplay devices 108 | ;; take care of this. 109 | ;; 110 | (setf *editor-file-descriptor* 0) 111 | (setf *editor-input* (make-tty-editor-input 0)))) 112 | (setf *real-editor-input* *editor-input*) 113 | *editor-windowed-input*) 114 | 115 | 116 | (defhvar "Raise Echo Area When Modified" 117 | "When set, Hemlock raises the echo area window when output appears there." 118 | :value nil) 119 | 120 | ;;; RAISE-ECHO-AREA-WHEN-MODIFIED -- Internal. 121 | ;;; 122 | ;;; INIT-BITMAP-SCREEN-MANAGER in bit-screen.lisp adds this hook when 123 | ;;; initializing the bitmap screen manager. 124 | ;;; 125 | (defun raise-echo-area-when-modified (buffer modified) 126 | (when (and (value hemlock::raise-echo-area-when-modified) 127 | (eq buffer *echo-area-buffer*) 128 | modified) 129 | (let* ((hunk (window-hunk *echo-area-window*)) 130 | (win (window-group-xparent (bitmap-hunk-window-group hunk)))) 131 | (xlib:map-window win) 132 | (setf (xlib:window-priority win) :above) 133 | (xlib:display-force-output 134 | (bitmap-device-display (device-hunk-device hunk)))))) 135 | -------------------------------------------------------------------------------- /src/charmacs.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; Implementation specific character-hacking macros and constants. 11 | ;;; 12 | (in-package :hemlock-internals) 13 | 14 | ;;; This file contains various constants and macros which are implementation or 15 | ;;; ASCII dependant. It contains some versions of CHAR-CODE which do not check 16 | ;;; types and ignore the top bit so that various structures can be allocated 17 | ;;; 128 long instead of 256, and we don't get errors if a loser visits a binary 18 | ;;; file. 19 | ;;; 20 | ;;; There are so many different constants and macros implemented the same. 21 | ;;; This is to separate various mechanisms; for example, in principle the 22 | ;;; char-code-limit for the syntax functions is independant of that for the 23 | ;;; searching functions 24 | ;;; 25 | 26 | 27 | 28 | 29 | ;;; Unicode has a large range of characters. The first 256 are stored in 30 | ;;; a vector, and the rest are stored in a hash table. A default for the 31 | ;;; hash table can be supplied. 32 | (defstruct character-set 33 | page0 34 | table 35 | default) 36 | 37 | (defun char-set-ref (set code) 38 | (cond ((< code 256) 39 | (let ((page0 (character-set-page0 set))) 40 | (aref page0 code))) 41 | (t 42 | (let ((table (character-set-table set)) 43 | (default (character-set-default set))) 44 | (gethash code table default))))) 45 | 46 | (defun (setf char-set-ref) (value set code) 47 | (cond ((< code 256) 48 | (let ((page0 (character-set-page0 set))) 49 | (setf (aref page0 code) value))) 50 | (t 51 | (let ((table (character-set-table set))) 52 | (setf (gethash code table) value))))) 53 | 54 | (defun hi::%sp-find-character-with-attribute (string start end table mask) 55 | (declare (simple-string string) 56 | (fixnum start end mask) 57 | (type character-set table)) 58 | "%SP-Find-Character-With-Attribute String, Start, End, Table, Mask 59 | The codes of the characters of String from Start to End are used as indices 60 | into the Table, which is a U-Vector of 8-bit bytes. When the number picked 61 | up from the table bitwise ANDed with Mask is non-zero, the current 62 | index into the String is returned. The corresponds to SCANC on the Vax." 63 | (do ((index start (1+ index))) 64 | ((= index end) nil) 65 | (declare (fixnum index)) 66 | (if (/= (logand (char-set-ref table (char-code (elt string index))) mask) 0) 67 | (return index)))) 68 | 69 | (defun hi::%sp-reverse-find-character-with-attribute (string start end table 70 | mask) 71 | (declare (simple-string string) 72 | (fixnum start end mask) 73 | (type character-set table)) 74 | "Like %SP-Find-Character-With-Attribute, only sdrawkcaB." 75 | (do ((index (1- end) (1- index))) 76 | ((< index start) nil) 77 | (declare (fixnum index)) 78 | (if (/= (logand (char-set-ref table (char-code (elt string index))) mask) 0) 79 | (return index)))) 80 | 81 | ;;; 82 | ;;; search-hash-code must be a function with the following 83 | ;;; properties: given any character it returns a number between 0 and 84 | ;;; 255, and the same hash code must be returned for the upper and 85 | ;;; lower case forms of each character. In ASCII this is can be done 86 | ;;; by ANDing out the 5'th bit. 87 | ;;; 88 | (defmacro search-hash-code (ch) 89 | `(logand (char-code ,ch) #x+DF)) 90 | 91 | ;;; Doesn't do anything special, but it should fast and not waste any time 92 | ;;; checking type and whatnot. 93 | (defmacro search-char-upcase (ch) 94 | `(char-upcase (the base-char ,ch))) 95 | 96 | 97 | 98 | ;;;; DO-ALPHA-CHARS. 99 | 100 | ;;; ALPHA-CHARS-LOOP loops from start-char through end-char binding var 101 | ;;; to the alphabetic characters and executing body. Note that the manual 102 | ;;; guarantees lower and upper case char codes to be separately in order, 103 | ;;; but other characters may be interspersed within that ordering. 104 | (defmacro alpha-chars-loop (var start-char end-char result body) 105 | (let ((n (gensym)) 106 | (end-char-code (gensym))) 107 | `(do ((,n (char-code ,start-char) (1+ ,n)) 108 | (,end-char-code (char-code ,end-char))) 109 | ((> ,n ,end-char-code) ,result) 110 | (let ((,var (code-char ,n))) 111 | (when (alpha-char-p ,var) 112 | ,@body))))) 113 | 114 | (defmacro do-alpha-chars ((var kind &optional result) &rest forms) 115 | "(do-alpha-chars (var kind [result]) . body). Kind is one of 116 | :lower, :upper, or :both, and var is bound to each character in 117 | order as specified under character relations in the manual. When 118 | :both is specified, lowercase letters are processed first." 119 | ;; ### Hmm, I added iso-latin-1 characters here, but this gets eaten 120 | ;; by the ALPHA-CHAR-P in ALPHA-CHARS-LOOP. --GB 2004-11-20 121 | (case kind 122 | (:both 123 | `(progn 124 | (alpha-chars-loop ,var #\a #\z nil ,forms) 125 | (alpha-chars-loop ,var (code-char 223) (code-char 246) nil ,forms) 126 | (alpha-chars-loop ,var (code-char 248) (code-char 255) nil ,forms) 127 | (alpha-chars-loop ,var #\A #\Z nil ,forms) 128 | (alpha-chars-loop ,var (code-char 192) (code-char 214) nil ,forms) 129 | (alpha-chars-loop ,var (code-char 216) (code-char 222) ,result ,forms) )) 130 | (:lower 131 | `(progn 132 | (alpha-chars-loop ,var (code-char 223) (code-char 246) ,forms) 133 | (alpha-chars-loop ,var (code-char 248) nil ,forms) 134 | (alpha-chars-loop ,var #\a #\z ,result ,forms) )) 135 | (:upper 136 | `(progn 137 | (alpha-chars-loop ,var #\A #\Z nil ,forms) 138 | (alpha-chars-loop ,var (code-char 192) (code-char 214) nil ,forms) 139 | (alpha-chars-loop ,var (code-char 216) (code-char 222) ,result ,forms) )) 140 | (t (error "Kind argument not one of :lower, :upper, or :both -- ~S." 141 | kind)))) 142 | -------------------------------------------------------------------------------- /doc/misc/compilation.order: -------------------------------------------------------------------------------- 1 | ; Definitions of structures intended for use within the HEMLOCK-INTERNALS 2 | ; package. 3 | Struct 4 | ; Definitions of structures intended for use within the HEMLOCK package. 5 | Struct-ed 6 | ; Code specific to CMU Common Lisp on the IBM RT/PC under Mach. 7 | rompsite 8 | ; Implementation dependant character hacking macros. 9 | Charmacs 10 | ; This is implementation dependent code for canonical input event 11 | ; representation. It also provides a interface for converting X11 codes 12 | ; and bits to an input event. 13 | Key-event 14 | Keysym-defs 15 | ; Implementation independent code to support input to Hemlock, based on 16 | ; keytran.lisp and keytrandefs.lisp. 17 | Input 18 | ; Random macros needed in the compiler. 19 | Macros 20 | ; Implementation dependant line structure definition. 21 | Line 22 | 23 | ; Ring-Buffer data-type primitives. 24 | Ring 25 | ; String-Table primitives. 26 | Table 27 | 28 | ; Text manipulation primitives. 29 | Htext1 30 | Htext2 31 | Htext3 32 | Htext4 33 | 34 | ; Searching and replacing primitives. 35 | Search1 ;String searches. 36 | Search2 ;Character searches, uses %sp-[reverse-]find-character-with-attribute. 37 | 38 | ; Stuff that depends on the current line-image building scheme, and 39 | ; thus %SP-Find-Character-With-Attribute. 40 | ; Build line images. 41 | Linimage 42 | ; Cursor-positioning and recentering stuff. 43 | Cursor 44 | 45 | ; Uses %SP-Find-Character-With-Attribute, but is independent of line-image 46 | ; stuff. 47 | ; Syntax table primitives. 48 | Syntax 49 | 50 | ; Window image building stuff. 51 | Winimage 52 | 53 | ; Implementation dependent redisplay code for running under X. 54 | Hunk-Draw 55 | 56 | ; Implementation independent interface to Unix style termcap files. 57 | Termcap 58 | 59 | ; Implementation independent redisplay entry points. 60 | Display 61 | 62 | ; Implementation dependent redisplay. 63 | Bit-display ;for bitmap displays under X. 64 | 65 | ; Implementation dependent redisplay code for running with a terminal. 66 | Tty-disp-rt 67 | 68 | ; Implementation independent redisplay code for running with a terminal. 69 | Tty-display 70 | 71 | ; Implementation dependent code for random typeout/pop-up displays on the 72 | ; bitmap and tty. 73 | pop-up-stream 74 | 75 | ; Implementation independent screen management. 76 | Screen 77 | 78 | ; Implementation dependent screen management. 79 | Bit-screen ;for bitmap display under X. 80 | 81 | ; Implementation independent screen management code for running with a terminal. 82 | Tty-screen 83 | 84 | ; Implementation independent code for Hemlock window primitives and 85 | ; some other redisplay stuff. 86 | Window 87 | 88 | ; Implementation independent interface to fonts. 89 | Font 90 | 91 | ; The command interpreter. 92 | Interp 93 | 94 | ; Hemlock variable access functions. 95 | Vars 96 | 97 | ; Buffer and mode manipulation functions 98 | Buffer 99 | 100 | ; Implementation dependent file primitives. 101 | Files 102 | 103 | ; Implemention dependent stream primitives. 104 | Streams 105 | 106 | ; echo-area prompting functions. 107 | Echo 108 | 109 | ; Random top-level user functions and implementation independant initilization 110 | ; stuff. 111 | Main 112 | 113 | ; Echo-Area commands. 114 | EchoComs 115 | 116 | ; Some character attribute definitions. 117 | Defsyn 118 | 119 | ; Basic commands 120 | Command 121 | MoreComs 122 | 123 | ; Stuff for undoing stuff. 124 | Undo 125 | 126 | ; Killing and un-killing commands. Mark ring primitives and commands. 127 | KillComs 128 | 129 | ; Searching and replacing commands. 130 | SearchComs 131 | 132 | ; File and buffer manipulating commands. 133 | Filecoms 134 | 135 | ; Indentation commands 136 | Indent 137 | 138 | ; Commands for lisp mode. 139 | Lispmode 140 | 141 | ; Comment-hacking commands. 142 | Comments 143 | 144 | ; Auto Fill Mode and filling commands. 145 | Fill 146 | 147 | ; Text primitives and commands (paragraphs, sentences, etc.) 148 | Text 149 | 150 | ; Documentation commands. 151 | Doccoms 152 | 153 | ; Commands for buffer comparison and stuff. 154 | Srccom 155 | 156 | ; Commands for manipulating groups of files. 157 | Group 158 | 159 | ; Implementation dependent spell code. 160 | Spell-RT 161 | ; Spelling correction interface implementation. 162 | Spell-Corr 163 | ; Spell interface to incrementally add to the dictionary. 164 | Spell-Aug 165 | ; Nearly implementation independent code to build binary dictionary. 166 | Spell-Build 167 | ; User interface commands. 168 | Spellcoms 169 | 170 | ; Word abbreviation commands. 171 | Abbrev 172 | 173 | ; Overwrite mode, for making text pictures and stuff. 174 | Overwrite 175 | 176 | ; Gosling Emacs bindings and twiddle chars command. Lots of other 177 | ;differences. 178 | gosmacs 179 | 180 | ; a typescript server in Hemlock. Client Lisp's *terminal-io* streams are 181 | ; set to typescript streams which send message requests to typescript servers 182 | ; for input and output, so this is how client Lisps can do full I/O inside 183 | ; a Hemlock buffer. 184 | Ts-buf 185 | Ts-stream 186 | 187 | ; commands for interacting with client Lisp environments and REP loops. 188 | eval-server 189 | Lispeval 190 | 191 | ; commands for evaling and running a REP loop in a buffer. 192 | Lispbuf 193 | 194 | ; Keyboard macros and stuff. 195 | Kbdmac 196 | 197 | ; Hackish thing to italicize comments. 198 | Icom 199 | 200 | ; Stuff to check buffer integrity. 201 | Integrity 202 | 203 | ; Scribe Mode 204 | Scribe 205 | 206 | ; Definition editing/function definition finding 207 | Edit-Defs 208 | 209 | ; auto-save mode. 210 | auto-save 211 | 212 | ; register code. stuff for stashing marks and regions in "registers". 213 | register 214 | 215 | ; commands pertinent only to the X windowing system. 216 | xcoms 217 | 218 | ; implements Unix specific commands for Hemlock. 219 | unixcoms 220 | 221 | ; mail interface to MH. 222 | mh 223 | 224 | ; highlighting parens and active regions. 225 | highlight 226 | 227 | ; directory editing; implementation dependent. 228 | dired 229 | diredcoms 230 | 231 | ; buffer hacking mode. 232 | bufed 233 | 234 | ; lisp library browser mode; implementation dependent. 235 | lisp-lib 236 | 237 | ; completion mode to save key strokes for long Lisp identifiers. 238 | completion 239 | 240 | ; "Process" mode, primarily implements Unix shells in Hemlock buffers. 241 | shell 242 | 243 | ; stuff for talking to slave Lisps to do debugging. 244 | debug 245 | 246 | ; site dependent NNTP interface for reading Netnews. 247 | netnews 248 | 249 | ; File that sets up all the default key bindings; implementation dependant. 250 | Bindings 251 | -------------------------------------------------------------------------------- /src/dabbrev.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | 4 | 5 | ;;; ********************************************************************** 6 | ;;; Dynamic abbreviation (dabbrev) command, knocked off from GNU Emacs. 7 | ;;; Written by Luke Gorrie in February 2002. 8 | ;;; This code has been placed in the public domain. 9 | 10 | (in-package :hemlock) 11 | 12 | ;;; ---------------------------------------------------------------------- 13 | ;;; Internal state for continuing expansions. This is only maintained 14 | ;;; between consecutive calls to Dabbrev Expand, and all gets reset when a 15 | ;;; new expansion is staretd. 16 | 17 | (defvar *expanded-suffix-length* nil 18 | "Length of the previously expanded suffix, or Nil if no expansion has 19 | been made. This length is needed to undo an expansion.") 20 | 21 | (defvar *seen-dabbrevs* nil 22 | "List of abbreviations that have already been offered, and will be 23 | skipped in future.") 24 | 25 | (defvar *dabbrev-continuation* nil 26 | "Closure which, when called with no arguments, continues from the 27 | previous expansion.") 28 | 29 | (defcommand "Dabbrev Expand" (p) 30 | "Expand previous word \"dynamically\". 31 | 32 | Expands to the most recent, preceding word for which this is a prefix. 33 | If no suitable preceding word is found, words following point are 34 | considered. 35 | 36 | Repeated calls continue by finding new expansions." 37 | "See command docstring. I mean, really." 38 | (declare (ignore p)) 39 | (if (eq (last-command-type) :dabbrev-expand) 40 | (continue-dabbrev-search) 41 | (new-dabbrev-search))) 42 | 43 | (defun continue-dabbrev-search () 44 | "Replace the previous expansion with the next new one." 45 | (funcall *dabbrev-continuation*)) 46 | 47 | (defun new-dabbrev-search () 48 | "Start a new search for an expansion." 49 | (reset-dabbrev-state) 50 | (let ((mark (copy-mark (current-point) :temporary))) 51 | (when (start-of-dabbrev-prefix mark) 52 | (let ((prefix (region-to-string (region mark (current-point))))) 53 | (if (string= prefix "") 54 | (editor-error "No possible abbreviation preceding point") 55 | (dabbrev-find-expansion mark :backward prefix)))))) 56 | 57 | (defun reset-dabbrev-state () 58 | (setq *expanded-suffix-length* nil 59 | *seen-dabbrevs* nil 60 | *dabbrev-continuation* nil)) 61 | 62 | (defun start-of-dabbrev-prefix (mark) 63 | "Move Mark to the beginning of the word containing it. Returns NIL if 64 | there is no matching word." 65 | (or (reverse-find-attribute mark :lisp-syntax #'not-constituent-p) 66 | (or (start-line-p mark) 67 | (line-start mark)))) 68 | 69 | ;;; ---------------------------------------------------------------------- 70 | ;;; Main searching engine 71 | 72 | (defun dabbrev-find-expansion (start-mark direction string) 73 | "Try to find an expansion of STRING in DIRECTION, starting from 74 | START-MARK. The expansion suffix is returned if found, otherwise NIL." 75 | (let ((searchm (copy-mark start-mark :temporary))) 76 | (if (find-pattern searchm 77 | (new-search-pattern :string-sensitive 78 | direction 79 | string)) 80 | ;; Marks to be placed for the region of the new suffix. 81 | (let ((start (copy-mark searchm :temporary)) 82 | (end (copy-mark searchm :temporary))) 83 | (character-offset start (length string)) 84 | (move-mark end start) 85 | (or (find-attribute end :lisp-syntax #'not-constituent-p) 86 | (line-end end)) 87 | (let ((match-region (region start end))) 88 | (cond ((and (> (count-characters match-region) 0) 89 | (at-beginning-of-word-p searchm) 90 | (not (member (region-to-string match-region) 91 | *seen-dabbrevs* 92 | :test #'string=))) 93 | (dabbrev-apply-expansion searchm match-region direction string)) 94 | ((and (eq direction :forward) 95 | (next-character end)) 96 | (dabbrev-find-expansion end direction string)) 97 | ((and (eq direction :backward) 98 | (previous-character searchm)) 99 | (dabbrev-find-expansion searchm direction string)) 100 | (t 101 | (continue-failed-expansion direction string))))) 102 | (continue-failed-expansion direction string)))) 103 | 104 | (defun continue-failed-expansion (direction string) 105 | "Continue (or not) the search, after one avenue has failed." 106 | (cond ((eq direction :backward) 107 | ;; Turn around -- now try forwards from Point 108 | (dabbrev-find-expansion (current-point) :forward string)) 109 | (t 110 | ;; We've tried both directions, so just give up. 111 | ;; Alternatively we could try other sources of abbreviations next. 112 | (undo-previous-expansion) 113 | (editor-error (if *seen-dabbrevs* 114 | "No more expansions of `~A'" 115 | "No expansion for `~A'") 116 | string)))) 117 | 118 | (defun dabbrev-apply-expansion (match region direction prefix) 119 | "Apply the expansion found at Match to the buffer by inserting the 120 | suffix in Region after the original prefix." 121 | (undo-previous-expansion) 122 | (setq *expanded-suffix-length* (count-characters region)) 123 | (let ((suffix (region-to-string region)) 124 | (search-continue-pos (if (eq direction :forward) 125 | (region-end region) 126 | match))) 127 | (push suffix *seen-dabbrevs*) 128 | (insert-string (current-point) suffix) 129 | (dabbrev-install-continuation 130 | (lambda () 131 | (dabbrev-find-expansion search-continue-pos direction prefix))))) 132 | 133 | (defun undo-previous-expansion () 134 | (when *expanded-suffix-length* 135 | (delete-characters (current-point) (- *expanded-suffix-length*)))) 136 | 137 | (defun dabbrev-install-continuation (k) 138 | (setf (last-command-type) :dabbrev-expand) 139 | (setq *dabbrev-continuation* k)) 140 | 141 | ;;; ---------------------------------------------------------------------- 142 | ;;; Little helpers 143 | 144 | (defun at-beginning-of-word-p (mark) 145 | (or (start-line-p mark) 146 | (not (eq (character-attribute 147 | :lisp-syntax 148 | (previous-character mark)) 149 | :constituent)))) 150 | 151 | (defun not-constituent-p (property) 152 | (not (eq property :constituent))) 153 | 154 | -------------------------------------------------------------------------------- /unused/tty-stream.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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: /home/david/phemlock/cvsroot/phemlock/unused/tty-stream.lisp,v 1.1 2004-07-09 13:39:14 gbaumann Exp $") 9 | ;;; 10 | ;;; ********************************************************************** 11 | ;;; 12 | ;;; Some stuff to make streams that write out to terminal hunks. 13 | ;;; 14 | ;;; Written by Bill Chiles. 15 | ;;; 16 | ;;; This code is VERY similar to that in Pane-Stream.Lisp. The biggest 17 | ;;; (if only) difference is in TTY-HUNK-STREAM-NEWLINE. 18 | ;;; 19 | 20 | (in-package "HEMLOCK-INTERNALS") 21 | 22 | 23 | 24 | ;;;; Constants 25 | 26 | (defconstant tty-hunk-width-limit 200) 27 | 28 | 29 | 30 | ;;;; Structures 31 | 32 | ;;; Tty-Hunk streams are inherently buffered by line. 33 | 34 | (defstruct (stream-hunk (:print-function %print-device-hunk) 35 | (:include tty-hunk)) 36 | (width 0 :type fixnum) 37 | (point-x 0 :type fixnum) 38 | (point-y 0 :type fixnum) 39 | (buffer "" :type simple-string)) 40 | 41 | (defstruct (tty-hunk-output-stream (:include sys:lisp-stream 42 | (out #'hunk-out) 43 | (sout #'hunk-sout) 44 | (misc #'hunk-misc)) 45 | (:constructor 46 | make-tty-hunk-output-stream ())) 47 | (hunk (make-stream-hunk :buffer (make-string tty-hunk-width-limit)))) 48 | 49 | 50 | 51 | ;;;; Tty-hunk-output-stream methods 52 | 53 | ;;; HUNK-OUT puts a character into a hunk-stream buffer. If the character 54 | ;;; makes the current line wrap, or if the character is a newline, then 55 | ;;; call TTY-HUNK-NEWLINE. 56 | ;;; 57 | (defun hunk-out (stream character) 58 | (let* ((hunk (tty-hunk-output-stream-hunk stream)) 59 | (x (stream-hunk-point-x hunk))) 60 | (declare (fixnum x)) 61 | (cond ((char= character #\newline) 62 | (tty-hunk-stream-newline hunk) 63 | (return-from hunk-out nil)) 64 | ((= x (the fixnum (stream-hunk-width hunk))) 65 | (setf x 0) 66 | (tty-hunk-stream-newline hunk))) 67 | (setf (schar (stream-hunk-buffer hunk) x) character) 68 | (incf (stream-hunk-point-x hunk)))) 69 | 70 | ;;; HUNK-MISC, when finishing or forcing output, only needs to blast 71 | ;;; out the buffer at y from 0 to x since these streams are inherently 72 | ;;; line buffered. Currently, these characters will be blasted out again 73 | ;;; since there isn't a separate buffer index from point-x, and we can't 74 | ;;; set point-x to zero since we haven't a newline. 75 | ;;; 76 | (defun hunk-misc (stream operation &optional arg1 arg2) 77 | (declare (ignore arg1 arg2)) 78 | (case operation 79 | (:charpos 80 | (let ((hunk (tty-hunk-output-stream-hunk stream))) 81 | (values (stream-hunk-point-x hunk) (stream-hunk-point-y hunk)))) 82 | ((:finish-output :force-output) 83 | (let* ((hunk (tty-hunk-output-stream-hunk stream)) 84 | (device (device-hunk-device hunk))) 85 | (funcall (tty-device-display-string device) 86 | hunk 0 (stream-hunk-point-y hunk) (stream-hunk-buffer hunk) 87 | 0 (stream-hunk-point-x hunk)) 88 | (when (device-force-output device) 89 | (funcall (device-force-output device))))) 90 | (:line-length 91 | (stream-hunk-width (tty-hunk-output-stream-hunk stream))) 92 | (:element-type 'base-char))) 93 | 94 | ;;; HUNK-SOUT writes a byte-blt's a string to a hunk-stream's buffer. 95 | ;;; When newlines are found, recurse on the substrings delimited by start, 96 | ;;; end, and newlines. If the string causes line wrapping, then we break 97 | ;;; the string up into line-at-a-time segments calling TTY-HUNK-STREAM-NEWLINE. 98 | ;;; 99 | (defun hunk-sout (stream string start end) 100 | (declare (fixnum start end)) 101 | (let* ((hunk (tty-hunk-output-stream-hunk stream)) 102 | (buffer (stream-hunk-buffer hunk)) 103 | (x (stream-hunk-point-x hunk)) 104 | (dst-end (+ x (- end start))) 105 | (width (stream-hunk-width hunk)) 106 | (newlinep (%sp-find-character string start end #\newline))) 107 | (declare (fixnum x dst-end width)) 108 | (cond (newlinep 109 | (let ((previous start) (current newlinep)) 110 | (declare (fixnum previous)) 111 | (loop (when (null current) 112 | (hunk-sout stream string previous end) 113 | (return)) 114 | (hunk-sout stream string previous current) 115 | (tty-hunk-stream-newline hunk) 116 | (setf previous (the fixnum (1+ (the fixnum current)))) 117 | (setf current 118 | (%sp-find-character string previous end #\newline))))) 119 | ((> dst-end width) 120 | (let ((new-start (+ start (- width x)))) 121 | (declare (fixnum new-start)) 122 | (%primitive byte-blt string start buffer x width) 123 | (setf (stream-hunk-point-x hunk) width) 124 | (tty-hunk-stream-newline hunk) 125 | (do ((idx (+ new-start width) (+ idx width)) 126 | (prev new-start idx)) 127 | ((>= idx end) 128 | (let ((dst-end (- end prev))) 129 | (%primitive byte-blt string prev buffer 0 dst-end) 130 | (setf (stream-hunk-point-x hunk) dst-end))) 131 | (declare (fixnum prev idx)) 132 | (%primitive byte-blt string prev buffer 0 width) 133 | (setf (stream-hunk-point-x hunk) width) 134 | (tty-hunk-stream-newline hunk)))) 135 | (t 136 | (%primitive byte-blt string start buffer x dst-end) 137 | (setf (stream-hunk-point-x hunk) dst-end))))) 138 | 139 | ;;; TTY-HUNK-STREAM-NEWLINE is the only place we display lines and affect 140 | ;;; point-y. We also blast out the buffer in HUNK-MISC. 141 | ;;; 142 | (defun tty-hunk-stream-newline (hunk) 143 | (let* ((device (device-hunk-device hunk)) 144 | (force-output-fun (device-force-output device)) 145 | (y (stream-hunk-point-y hunk))) 146 | (declare (fixnum y)) 147 | (when (= y (the fixnum (device-hunk-position hunk))) 148 | (funcall (tty-device-display-string device) hunk 0 y "--More--" 0 8) 149 | (when force-output-fun (funcall force-output-fun)) 150 | (wait-for-more) 151 | (funcall (tty-device-clear-to-eow device) hunk 0 0) 152 | (setf (stream-hunk-point-y hunk) 0) 153 | (setf y 0)) 154 | (funcall (tty-device-display-string device) 155 | hunk 0 y (stream-hunk-buffer hunk) 0 (stream-hunk-point-x hunk)) 156 | (when force-output-fun (funcall force-output-fun)) 157 | (setf (stream-hunk-point-x hunk) 0) 158 | (incf (stream-hunk-point-y hunk)))) 159 | -------------------------------------------------------------------------------- /src/register.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; Registers for holding text and positions. 11 | ;;; 12 | ;;; Written by Dave Touretzky. 13 | ;;; Modified by Bill Chiles for Hemlock consistency. 14 | ;;; 15 | (in-package :hemlock) 16 | 17 | 18 | 19 | ;;;; Registers implementation. 20 | 21 | ;;; Registers are named by characters. Each register refers to a mark or 22 | ;;; a cons of a region and the buffer it came from. 23 | ;;; 24 | (defvar *registers* (make-hash-table)) 25 | 26 | (defun register-count () 27 | (hash-table-count *registers*)) 28 | 29 | (defun register-value (reg-name) 30 | (gethash reg-name *registers*)) 31 | 32 | (defsetf register-value (reg-name) (new-value) 33 | (let ((name (gensym)) 34 | (value (gensym)) 35 | (old-value (gensym))) 36 | `(let* ((,name ,reg-name) 37 | (,value ,new-value) 38 | (,old-value (gethash ,name *registers*))) 39 | (when (and ,old-value (markp ,old-value)) 40 | (delete-mark ,old-value)) 41 | (setf (gethash ,name *registers*) ,value)))) 42 | 43 | (defun prompt-for-register (&optional (prompt "Register: ") must-exist) 44 | (let ((reg-name (prompt-for-key-event :prompt prompt))) 45 | (unless (or (not must-exist) (gethash reg-name *registers*)) 46 | (editor-error "Register ~A is empty." reg-name)) 47 | reg-name)) 48 | 49 | 50 | (defmacro do-registers ((name value &optional sorted) &rest body) 51 | (if sorted 52 | (let ((sorted-regs (gensym)) 53 | (reg (gensym))) 54 | `(let ((,sorted-regs nil)) 55 | (declare (list ,sorted-regs)) 56 | (maphash #'(lambda (,name ,value) 57 | (push (cons ,name ,value) ,sorted-regs)) 58 | *registers*) 59 | (setf ,sorted-regs (sort ,sorted-regs #'char-lessp :key #'car)) 60 | (dolist (,reg ,sorted-regs) 61 | (let ((,name (car ,reg)) 62 | (,value (cdr ,reg))) 63 | ,@body)))) 64 | `(maphash #'(lambda (,name ,value) 65 | ,@body) 66 | *registers*))) 67 | 68 | 69 | ;;; Hook to clean things up if a buffer is deleted while registers point to it. 70 | ;;; 71 | (defun flush-reg-references-to-deleted-buffer (buffer) 72 | (do-registers (name value) 73 | (etypecase value 74 | (mark (when (eq (line-buffer (mark-line value)) buffer) 75 | (free-register name))) 76 | (cons (free-register-value value buffer))))) 77 | ;;; 78 | (add-hook delete-buffer-hook 'flush-reg-references-to-deleted-buffer) 79 | 80 | 81 | (defun free-register (name) 82 | (let ((value (register-value name))) 83 | (when value (free-register-value value))) 84 | (remhash name *registers*)) 85 | 86 | (defun free-register-value (value &optional buffer) 87 | (etypecase value 88 | (mark 89 | (when (or (not buffer) (eq (line-buffer (mark-line value)) buffer)) 90 | (delete-mark value))) 91 | (cons 92 | (when (and buffer (eq (cdr value) buffer)) 93 | (setf (cdr value) nil))))) 94 | 95 | 96 | 97 | ;;;; Commands. 98 | 99 | ;;; These commands all stash marks and regions with marks that point into some 100 | ;;; buffer, and they assume that the register values have the same property. 101 | ;;; 102 | 103 | (defcommand "Save Position" (p) 104 | "Saves the current location in a register. Prompts for register name." 105 | "Saves the current location in a register. Prompts for register name." 106 | (declare (ignore p)) 107 | (let ((reg-name (prompt-for-register))) 108 | (setf (register-value reg-name) 109 | (copy-mark (current-point) :left-inserting)))) 110 | 111 | (defcommand "Jump to Saved Position" (p) 112 | "Moves the point to a location previously saved in a register." 113 | "Moves the point to a location previously saved in a register." 114 | (declare (ignore p)) 115 | (let* ((reg-name (prompt-for-register "Jump to Register: " t)) 116 | (val (register-value reg-name))) 117 | (unless (markp val) 118 | (editor-error "Register ~A does not hold a location." reg-name)) 119 | (change-to-buffer (line-buffer (mark-line val))) 120 | (move-mark (current-point) val))) 121 | 122 | (defcommand "Kill Register" (p) 123 | "Kill a regist er. Prompts for the name." 124 | "Kill a register. Prompts for the name." 125 | (declare (ignore p)) 126 | (free-register (prompt-for-register "Register to kill: "))) 127 | 128 | (defcommand "List Registers" (p) 129 | "Lists all registers in a pop-up window." 130 | "Lists all registers in a pop-up window." 131 | (declare (ignore p)) 132 | (with-pop-up-display (f :height (* 2 (register-count))) 133 | (do-registers (name val :sorted) 134 | (write-string "Reg " f) 135 | (hemlock-ext:print-pretty-key-event name f) 136 | (write-string ": " f) 137 | (etypecase val 138 | (mark 139 | (let* ((line (mark-line val)) 140 | (buff (line-buffer line)) 141 | (len (line-length line))) 142 | (format f "Line ~S, col ~S in buffer ~A~% ~A~:[~;...~]~%" 143 | (count-lines (region (buffer-start-mark buff) val)) 144 | (mark-column val) 145 | (buffer-name buff) 146 | (subseq (line-string line) 0 (min 61 len)) 147 | (> len 60)))) 148 | (cons 149 | (let* ((str (region-to-string (car val))) 150 | (nl (position #\newline str :test #'char=)) 151 | (len (length str)) 152 | (buff (cdr val))) 153 | (declare (simple-string str)) 154 | (format f "Text~@[ from buffer ~A~]~% ~A~:[~;...~]~%" 155 | (if buff (buffer-name buff)) 156 | (subseq str 0 (if nl (min 61 len nl) (min 61 len))) 157 | (> len 60)))))))) 158 | 159 | (defcommand "Put Register" (p) 160 | "Copies a region into a register. Prompts for register name." 161 | "Copies a region into a register. Prompts for register name." 162 | (declare (ignore p)) 163 | (let ((region (current-region))) 164 | ;; Bind the region before prompting in case the region isn't active. 165 | (setf (register-value (prompt-for-register)) 166 | (cons (copy-region region) (current-buffer))))) 167 | 168 | (defcommand "Get Register" (p) 169 | "Copies a region from a register to the current point." 170 | "Copies a region from a register to the current point." 171 | (declare (ignore p)) 172 | (let* ((reg-name (prompt-for-register "Register from which to get text: " t)) 173 | (val (register-value reg-name))) 174 | (unless (and (consp val) (regionp (car val))) 175 | (editor-error "Register ~A does not hold a region." reg-name)) 176 | (let ((point (current-point))) 177 | (push-buffer-mark (copy-mark point)) 178 | (insert-region (current-point) (car val)))) 179 | (setf (last-command-type) :ephemerally-active)) 180 | -------------------------------------------------------------------------------- /src/xref.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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 | ;;; 8 | ;;; ********************************************************************** 9 | ;;; 10 | ;;; This file contains Xref code, for M-. and other commands. 11 | ;;; 12 | 13 | (in-package :hemlock) 14 | 15 | 16 | 17 | (defvar *xref-entries* nil) 18 | (defvar *xref-entries-end* nil) 19 | ;;; 20 | 21 | (defstruct (xref-entry 22 | (:constructor internal-make-xref-entry (name file position))) 23 | name 24 | file 25 | position) 26 | 27 | (defun make-xref-entry (alist) 28 | (let* ((location (cdr (assoc :location (cdr alist)))) 29 | (file (second (assoc :file location))) 30 | (position (second (assoc :position location)))) 31 | (internal-make-xref-entry (car alist) 32 | file 33 | position))) 34 | 35 | ;;; This is the xref buffer if it exists. 36 | ;;; 37 | (defvar *xref-buffer* nil) 38 | 39 | ;;; This is the cleanup method for deleting *xref-buffer*. 40 | ;;; 41 | (defun delete-xref-buffers (buffer) 42 | (when (eq buffer *xref-buffer*) 43 | (setf *xref-buffer* nil) 44 | (setf *xref-entries* nil))) 45 | 46 | 47 | ;;;; Commands. 48 | 49 | (defmode "Xref" :major-p t 50 | :documentation 51 | "Xref lists Lisp definitions.") 52 | 53 | (defcommand "Xref Quit" (p) 54 | "Kill the xref buffer." 55 | "" 56 | (declare (ignore p)) 57 | (when *xref-buffer* (delete-buffer-if-possible *xref-buffer*))) 58 | 59 | (defcommand "Xref Goto" (p) 60 | "Change to the entry's buffer." 61 | "Change to the entry's buffer." 62 | (declare (ignore p)) 63 | (let ((entry (array-element-from-mark (current-point) *xref-entries*))) 64 | (when entry 65 | (change-to-definition entry)))) 66 | 67 | (defun refresh-xref (buf entries) 68 | (with-writable-buffer (buf) 69 | (delete-region (buffer-region buf)) 70 | (setf *xref-entries-end* (length entries)) 71 | (setf *xref-entries* (coerce entries 'vector)) 72 | (with-output-to-mark (s (buffer-point buf)) 73 | (dolist (entry entries) 74 | (xref-write-line entry s))))) 75 | 76 | (defun make-xref-buffer (entries) 77 | (let ((buf (or *xref-buffer* (make-buffer "*Xref*" :modes '("Xref"))))) 78 | (setf *xref-buffer* buf) 79 | (refresh-xref buf entries) 80 | (let ((fields (buffer-modeline-fields *xref-buffer*))) 81 | (setf (cdr (last fields)) 82 | (list (or (modeline-field :xref-cmds) 83 | (make-modeline-field 84 | :name :xref-cmds :width 18 85 | :function 86 | #'(lambda (buffer window) 87 | (declare (ignore buffer window)) 88 | " Type ? for help."))))) 89 | (setf (buffer-modeline-fields *xref-buffer*) fields)) 90 | (buffer-start (buffer-point buf)) 91 | (change-to-buffer buf))) 92 | 93 | (defun xref-write-line (entry s) 94 | (format s " ~A ~40T~A~%" 95 | (shorten-string 36 (xref-entry-name entry)) 96 | (shorten-string 39 (xref-entry-file entry)))) 97 | 98 | (defun shorten-string (len str) 99 | (if (<= (length str) len) 100 | str 101 | (concat (subseq str 0 (floor (- len 3) 2)) 102 | "..." 103 | (subseq str (- (length str) (ceiling (- len 3) 2)))))) 104 | 105 | (defcommand "Xref Help" (p) 106 | "Show this help." 107 | "Show this help." 108 | (declare (ignore p)) 109 | (describe-mode-command nil "Xref")) 110 | 111 | 112 | ;;; Find Definition 113 | 114 | (defun change-to-definition (entry) 115 | (let ((file (xref-entry-file entry)) 116 | (position (xref-entry-position entry))) 117 | (when file 118 | (change-to-buffer (find-file-buffer file)) 119 | (when position 120 | (buffer-start (current-point)) 121 | (character-offset (current-point) (1- position))) 122 | t))) 123 | 124 | (defun %find-definitions (label xref-fun name) 125 | (let* ((sym (hemlock::resolve-slave-symbol name nil)) 126 | (data 127 | (and sym 128 | (mapcar (lambda (def) 129 | (cons (princ-to-string (car def)) 130 | (cdr def))) 131 | (funcall xref-fun sym))))) 132 | (hemlock::eval-in-master `(%definitions-found ',label ',name ',data)))) 133 | 134 | (defun %definitions-found (label name data) 135 | (let ((entries (mapcar #'make-xref-entry data))) 136 | (cond 137 | ((null entries) 138 | (message "No ~A results for: ~A" label name)) 139 | ((null (cdr entries)) 140 | (change-to-definition (car entries))) 141 | (t 142 | (make-xref-buffer entries))))) 143 | 144 | (defun find-definitions (name) 145 | (hemlock::eval-in-slave 146 | `(%find-definitions "definition" 'conium:find-definitions ',name))) 147 | 148 | (defcommand "Find Definitions" (p) 149 | "" "" 150 | (let ((default (hemlock::symbol-string-at-point))) 151 | ;; Fixme: MARK-SYMBOL isn't very good, meaning that often we 152 | ;; will get random forms rather than a symbol. Let's at least 153 | ;; catch the case where the result is more than a line long, 154 | ;; and give up. 155 | (when (find #\newline default) 156 | (setf default nil)) 157 | (find-definitions 158 | (hemlock::parse-slave-symbol 159 | (if (or p (not default)) 160 | (hemlock-interface::prompt-for-string 161 | :prompt "Name: " 162 | :default default) 163 | default))))) 164 | 165 | (macrolet 166 | ((% (name fun conium-fun) 167 | `(progn 168 | (defcommand ,name (p) 169 | "" "" 170 | (let ((default (hemlock::symbol-string-at-point))) 171 | ;; Fixme: MARK-SYMBOL isn't very good, meaning that often we 172 | ;; will get random forms rather than a symbol. Let's at least 173 | ;; catch the case where the result is more than a line long, 174 | ;; and give up. 175 | (when (find #\newline default) 176 | (setf default nil)) 177 | (,fun 178 | (hemlock::parse-slave-symbol 179 | (if (or p (not default)) 180 | (hemlock-interface::prompt-for-string 181 | :prompt "Name: " 182 | :default default) 183 | default))))) 184 | (defun ,fun (name) 185 | (hemlock::eval-in-slave 186 | (list '%find-definitions 187 | (list 'quote ',name) 188 | (list 'quote ',conium-fun) 189 | (list 'quote name))))))) 190 | (% "Who Calls" who-calls conium:who-calls) 191 | (% "Who References" who-references conium:who-references) 192 | (% "Who Binds" who-binds conium:who-binds) 193 | (% "Who Sets" who-sets conium:who-sets) 194 | (% "Who Macroexpands" who-macroexpands conium:who-macroexpands) 195 | (% "Who Specializes" who-specializes conium:who-specializes)) 196 | -------------------------------------------------------------------------------- /unused/bit-stream.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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: /home/david/phemlock/cvsroot/phemlock/unused/bit-stream.lisp,v 1.1 2004-07-09 13:39:10 gbaumann Exp $") 9 | ;;; 10 | ;;; ********************************************************************** 11 | ;;; 12 | ;;; Some stuff to make streams that write out on bitmap hunks. 13 | ;;; 14 | ;;; Written by Rob MacLachlan. 15 | ;;; Modified by Bill Chiles to run under X on the IBM RT. 16 | ;;; 17 | (in-package "HEMLOCK-INTERNALS") 18 | 19 | 20 | ;;; These streams have an associated bitmap-hunk that is used for its 21 | ;;; font-family, foreground and background color, and X window pointer. 22 | ;;; The hunk need not be associated with any Hemlock window, and the low 23 | ;;; level painting routines that use hunk dimensions are not used for 24 | ;;; output. Only BITMAP-HUNK-WRITE-STRING is used. The hunk is not 25 | ;;; registered for any event service, so resizing the associated X window 26 | ;;; does not invoke the exposed/changed handler in Bit-Screen.Lisp; also, the 27 | ;;; hunk's input and changed handler slots are not set. 28 | ;;; 29 | (defstruct (bitmap-hunk-output-stream (:include sys:lisp-stream 30 | (out #'bitmap-hunk-out) 31 | (sout #'bitmap-hunk-sout) 32 | (misc #'bitmap-hunk-misc)) 33 | (:constructor 34 | make-bitmap-hunk-output-stream (hunk))) 35 | hunk ; bitmap-hunk we display on. 36 | (cursor-x 0) ; Character position of output cursor. 37 | (cursor-y 0) 38 | (buffer (make-string hunk-width-limit) :type simple-string) 39 | (old-bottom 0)) ; # of lines of scrolling before next "--More--" prompt. 40 | 41 | ;;; Bitmap-Hunk-Stream-Newline -- Internal 42 | ;;; 43 | ;;; Flush the stream's output buffer and then move the cursor down 44 | ;;; or scroll the window up if there is no room left. 45 | ;;; 46 | (defun bitmap-hunk-stream-newline (stream) 47 | (let* ((hunk (bitmap-hunk-output-stream-hunk stream)) 48 | (height (bitmap-hunk-char-height hunk)) 49 | (y (bitmap-hunk-output-stream-cursor-y stream))) 50 | (when (zerop (bitmap-hunk-output-stream-old-bottom stream)) 51 | (hunk-write-string hunk 0 y "--More--" 0 8) 52 | (let ((device (device-hunk-device hunk))) 53 | (when (device-force-output device) 54 | (funcall (device-force-output device)))) 55 | (wait-for-more) 56 | (hunk-clear-lines hunk y 1) 57 | (setf (bitmap-hunk-output-stream-old-bottom stream) (1- height))) 58 | (hunk-write-string hunk 0 y (bitmap-hunk-output-stream-buffer stream) 0 59 | (bitmap-hunk-output-stream-cursor-x stream)) 60 | (setf (bitmap-hunk-output-stream-cursor-x stream) 0) 61 | (decf (bitmap-hunk-output-stream-old-bottom stream)) 62 | (incf y) 63 | (when (= y height) 64 | (decf y) 65 | (hunk-copy-lines hunk 1 0 y) 66 | (hunk-clear-lines hunk y 1)) 67 | (setf (bitmap-hunk-output-stream-cursor-y stream) y))) 68 | 69 | ;;; Bitmap-Hunk-Misc -- Internal 70 | ;;; 71 | ;;; This is the misc method for bitmap-hunk-output-streams. It just 72 | ;;; writes out the contents of the buffer, and does the element type. 73 | ;;; 74 | (defun bitmap-hunk-misc (stream operation &optional arg1 arg2) 75 | (declare (ignore arg1 arg2)) 76 | (case operation 77 | (:charpos 78 | (values (bitmap-hunk-output-stream-cursor-x stream) 79 | (bitmap-hunk-output-stream-cursor-y stream))) 80 | ((:finish-output :force-output) 81 | (hunk-write-string (bitmap-hunk-output-stream-hunk stream) 82 | 0 (bitmap-hunk-output-stream-cursor-y stream) 83 | (bitmap-hunk-output-stream-buffer stream) 0 84 | (bitmap-hunk-output-stream-cursor-x stream)) 85 | (let ((device (device-hunk-device (bitmap-hunk-output-stream-hunk stream)))) 86 | (when (device-force-output device) 87 | (funcall (device-force-output device))))) 88 | (:line-length 89 | (bitmap-hunk-char-width (bitmap-hunk-output-stream-hunk stream))) 90 | (:element-type 'base-char))) 91 | 92 | 93 | ;;; Bitmap-Hunk-Out -- Internal 94 | ;;; 95 | ;;; Throw a character in a bitmap-hunk-stream's buffer. If we wrap or hit a 96 | ;;; newline then call bitmap-hunk-stream-newline. 97 | ;;; 98 | (defun bitmap-hunk-out (stream character) 99 | (let ((hunk (bitmap-hunk-output-stream-hunk stream)) 100 | (x (bitmap-hunk-output-stream-cursor-x stream))) 101 | (cond ((char= character #\newline) 102 | (bitmap-hunk-stream-newline stream) 103 | (return-from bitmap-hunk-out nil)) 104 | ((= x (bitmap-hunk-char-width hunk)) 105 | (setq x 0) 106 | (bitmap-hunk-stream-newline stream))) 107 | (setf (schar (bitmap-hunk-output-stream-buffer stream) x) character) 108 | (setf (bitmap-hunk-output-stream-cursor-x stream) (1+ x)))) 109 | 110 | 111 | ;;; Bitmap-Hunk-Sout -- Internal 112 | ;;; 113 | ;;; Write a string out to a bitmap-hunk, calling ourself recursively if the 114 | ;;; string contains newlines. 115 | ;;; 116 | (defun bitmap-hunk-sout (stream string start end) 117 | (let* ((hunk (bitmap-hunk-output-stream-hunk stream)) 118 | (buffer (bitmap-hunk-output-stream-buffer stream)) 119 | (x (bitmap-hunk-output-stream-cursor-x stream)) 120 | (dst-end (+ x (- end start))) 121 | (width (bitmap-hunk-char-width hunk))) 122 | (cond ((%primitive find-character string start end #\newline) 123 | (do ((current (%primitive find-character string start end #\newline) 124 | (%primitive find-character string (1+ current) 125 | end #\newline)) 126 | (previous start (1+ current))) 127 | ((null current) 128 | (bitmap-hunk-sout stream string previous end)) 129 | (bitmap-hunk-sout stream string previous current) 130 | (bitmap-hunk-stream-newline stream))) 131 | ((> dst-end width) 132 | (let ((new-start (+ start (- width x)))) 133 | (%primitive byte-blt string start buffer x width) 134 | (setf (bitmap-hunk-output-stream-cursor-x stream) width) 135 | (bitmap-hunk-stream-newline stream) 136 | (do ((idx (+ new-start width) (+ idx width)) 137 | (prev new-start idx)) 138 | ((>= idx end) 139 | (let ((dst-end (- end prev))) 140 | (%primitive byte-blt string prev buffer 0 dst-end) 141 | (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end))) 142 | (%primitive byte-blt string prev buffer 0 width) 143 | (setf (bitmap-hunk-output-stream-cursor-x stream) width) 144 | (bitmap-hunk-stream-newline stream)))) 145 | (t 146 | (%primitive byte-blt string start buffer x dst-end) 147 | (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end))))) 148 | -------------------------------------------------------------------------------- /unused/hemlock.system: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | (proclaim '(optimize (safety 3) (speed 0) (debug 3))) 4 | 5 | (defpackage #:hemlock-system 6 | (:use #:cl) 7 | (:export #:*hemlock-base-directory*)) 8 | 9 | (in-package #:hemlock-system) 10 | 11 | (pushnew :command-bits *features*) 12 | (pushnew :buffered-lines *features*) 13 | 14 | (defparameter *hemlock-base-directory* 15 | (make-pathname :name nil :type nil :version nil 16 | :defaults (parse-namestring *load-truename*))) 17 | 18 | (defparameter *binary-pathname* 19 | (make-pathname :directory 20 | (append (pathname-directory *hemlock-base-directory*) 21 | (list "bin" 22 | #+CLISP "clisp" 23 | #+CMU "cmu" 24 | #+EXCL "acl" 25 | #+SBCL "sbcl" 26 | #-(or CLISP CMU EXCL SBCL) 27 | (string-downcase (lisp-implementation-type)))) 28 | :defaults *hemlock-base-directory*)) 29 | 30 | (mk:defsystem :hemlock 31 | :source-pathname #.(make-pathname 32 | :directory 33 | (append (pathname-directory *hemlock-base-directory*) 34 | (list "src")) 35 | :defaults *hemlock-base-directory*) 36 | :source-extension "lisp" 37 | :binary-pathname #.*binary-pathname* 38 | :depends-on (:clim-clx #+NIL :mcclim-freetype) 39 | ;; ehem .. 40 | :initially-do 41 | (progn 42 | ;; try to load clx 43 | (unless (ignore-errors (fboundp (find-symbol "OPEN-DISPLAY" "XLIB"))) 44 | (ignore-errors (require :clx)) 45 | (ignore-errors (require :cmucl-clx))) 46 | (unless (ignore-errors (fboundp (find-symbol "OPEN-DISPLAY" "XLIB"))) 47 | (error "Please provide me with CLX.")) 48 | ;; Create binary pathnames 49 | (ensure-directories-exist *binary-pathname*) 50 | (dolist (subdir '("tty" "wire" "user" "core" "clim")) 51 | (ensure-directories-exist 52 | (merge-pathnames (make-pathname :directory (list :relative subdir)) 53 | *binary-pathname*) 54 | :verbose t)) 55 | ;; Gray Streams 56 | #+CMU 57 | (require :gray-streams) 58 | #+CMU 59 | (setf ext:*efficiency-note-cost-threshold* most-positive-fixnum) 60 | #+CMU 61 | (setf ext:*efficiency-note-limit* 0) 62 | #+CMU 63 | (proclaim '(optimize (c::brevity 3))) 64 | #+CMU 65 | (setf c:*record-xref-info* t) 66 | ) 67 | :components 68 | ((:module core-1 69 | :source-pathname "core" 70 | :components 71 | ((:file "package") 72 | ;; Lisp implementation specific stuff goes into one of the next 73 | ;; two files. 74 | (:file "lispdep") 75 | (:file "hemlock-ext") 76 | 77 | (:file "decls") ; early declarations of functions and stuff 78 | (:file "struct") 79 | ;; "struct-ed" 80 | (:file "charmacs") 81 | (:file "key-event"))) 82 | (:module bitmap-1 83 | :source-pathname "bitmap" 84 | :depends-on (core-1) 85 | :components 86 | ((:file "keysym-defs") ; hmm. 87 | (:file "bit-stuff") ; input depends on it --amb 88 | (:file "hunk-draw"))) ; window depends on it --amb 89 | (:module core-2 90 | :source-pathname "core" 91 | :depends-on (bitmap-1) 92 | :components 93 | ((:file "rompsite") 94 | (:file "input") 95 | (:file "macros") 96 | (:file "line") 97 | (:file "ring") 98 | (:file "htext1") ; buffer depends on it --amb 99 | (:file "buffer") 100 | (:file "vars") 101 | (:file "interp") 102 | (:file "syntax") 103 | (:file "htext2") 104 | (:file "htext3") 105 | (:file "htext4") 106 | (:file "files") 107 | (:file "search1") 108 | (:file "search2") 109 | (:file "table") 110 | 111 | (:file "winimage") 112 | (:file "window") 113 | (:file "screen") 114 | (:file "linimage") 115 | (:file "cursor") 116 | (:file "display"))) 117 | (:module tty-1 118 | :source-pathname "tty" 119 | :components 120 | (#+port-tty-termcap (:file "termcap") 121 | #+port-tty-tty-disp-rt (:file "tty-disp-rt") 122 | #+port-tty-tty-display (:file "tty-display"))) 123 | (:module root-1 124 | :source-pathname "" 125 | :depends-on (core-2) 126 | :components 127 | ((:file "pop-up-stream"))) 128 | (:module tty-2 129 | :source-pathname "tty" 130 | :components 131 | (#+port-tty-tty-screen (:file "tty-screen"))) 132 | (:module root-2 133 | :source-pathname "" 134 | :depends-on (root-1) 135 | :components 136 | ((:file "font") 137 | (:file "streams") 138 | #+port-root-hacks (:file "hacks") 139 | (:file "main") 140 | (:file "echo") 141 | (:file "new-undo"))) 142 | (:module user-1 143 | :source-pathname "user" 144 | :depends-on (root-2) 145 | :components 146 | ((:file "echocoms") 147 | 148 | (:file "command") 149 | (:file "kbdmac") 150 | (:file "undo") 151 | (:file "killcoms") 152 | (:file "indent") 153 | (:file "searchcoms") 154 | (:file "filecoms") 155 | (:file "morecoms") 156 | (:file "doccoms") 157 | (:file "srccom") 158 | (:file "group") 159 | (:file "fill") 160 | (:file "text") 161 | 162 | (:file "lispmode") 163 | #+port-user-ts-buf (:file "ts-buf") 164 | #+port-user-ts-stream (:file "ts-stream") 165 | #+port-user-eval-server (:file "eval-server") 166 | (:file "lispbuf") 167 | #+port-user-lispeval (:file "lispeval") 168 | #+port-user-spell-rt (:file "spell-rt") 169 | #+port-user-spell-corr (:file "spell-corr") 170 | #+port-user-spell-aug (:file "spell-aug") 171 | #+port-user-spellcoms (:file "spellcoms") 172 | 173 | (:file "comments") 174 | (:file "overwrite") 175 | (:file "abbrev") 176 | (:file "icom") 177 | (:file "defsyn") 178 | (:file "scribe") 179 | (:file "pascal") 180 | (:file "dylan") 181 | 182 | (:file "edit-defs") 183 | (:file "auto-save") 184 | (:file "register") 185 | (:file "xcoms") 186 | #+port-user-unixcoms (:file "unixcoms") 187 | #+port-user-mh (:file "mh") 188 | (:file "highlight") 189 | #+port-user-dired (:file "dired") 190 | #+port-user-diredcoms (:file "diredcoms") 191 | (:file "bufed") 192 | #+port-user-lisp-lib (:file "lisp-lib") 193 | (:file "completion") 194 | #+port-user-shell (:file "shell") 195 | #+port-user-debug (:file "debug") 196 | #+port-user-netnews (:file "netnews") 197 | #+port-user-rcs (:file "rcs") 198 | (:file "dabbrev") 199 | (:file "bindings") 200 | (:file "bindings-gb"))) 201 | (:module bitmap-2 202 | :source-pathname "bitmap" 203 | :depends-on (user-1) 204 | :components 205 | ((:file "rompsite") 206 | (:file "input") 207 | (:file "bit-screen") 208 | (:file "bit-display") 209 | (:file "pop-up-stream"))) 210 | (:module clim-1 211 | :source-pathname "clim" 212 | :depends-on (bitmap-2) 213 | :components 214 | ((:file "patch") 215 | (:file "foo") )))) 216 | -------------------------------------------------------------------------------- /unused/ed-integrity.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 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: /home/david/phemlock/cvsroot/phemlock/unused/ed-integrity.lisp,v 1.1 2004-07-09 13:39:12 gbaumann Exp $") 9 | ;;; 10 | ;;; ********************************************************************** 11 | ;;; 12 | ;;; This stuff can be used for testing tty redisplay. There are four 13 | ;;; commands that, given "Setup Tty Buffer", that test 14 | ;;; HI::COMPUTE-TTY-CHANGES: "Two Deletes", "Two Inserts", "One Delete One 15 | ;;; Insert", and "One Insert One Delete. Each can be called with an 16 | ;;; argument to generate a grand total of eight screen permutations. 17 | ;;; "Setup Tty Buffer" numbers the lines of the main window 0 through 19 18 | ;;; inclusively. 19 | ;;; 20 | ;;; "Setup for Debugging" and "Cleanup for Debugging" were helpful in 21 | ;;; conjunction with some alternate versions of COMPUTE-TTY-CHANGES and 22 | ;;; TTY-SMART-WINDOW-REDISPLAY. When something went wrong with on 23 | 24 | (in-package "ED") 25 | 26 | 27 | (declaim (special hemlock-internals::*debugging-tty-redisplay* 28 | hemlock-internals::*testing-delete-queue* 29 | hemlock-internals::*testing-insert-queue* 30 | hemlock-internals::*testing-moved* 31 | hemlock-internals::*testing-writes*)) 32 | 33 | 34 | (defcommand "Setup Tty Buffer" (p) 35 | "Clear buffer and insert numbering strings 0..19." 36 | "Clear buffer and insert numbering strings 0..19." 37 | (declare (ignore p)) 38 | (delete-region (buffer-region (current-buffer))) 39 | (let ((point (current-point))) 40 | (dotimes (i 20) 41 | (insert-string point (prin1-to-string i)) 42 | (insert-character point #\newline)) 43 | (buffer-start point))) 44 | 45 | (defcommand "Setup for Debugging" (p) 46 | "Set *debugging-tty-redisplay* to t, and some other stuff to nil." 47 | "Set *debugging-tty-redisplay* to t, and some other stuff to nil." 48 | (declare (ignore p)) 49 | (setf hi::*debugging-tty-redisplay* t) 50 | (setf hi::*testing-delete-queue* nil) 51 | (setf hi::*testing-insert-queue* nil) 52 | (setf hi::*testing-moved* nil) 53 | (setf hi::*testing-writes* nil)) 54 | 55 | (defcommand "Cleanup for Debugging" (p) 56 | "Set *debugging-tty-redisplay* to nil." 57 | "Set *debugging-tty-redisplay* to nil." 58 | (declare (ignore p)) 59 | (setf hi::*debugging-tty-redisplay* nil)) 60 | 61 | ;;; Given "Setup Tty Buffer", deletes lines numbered 3, 4, 5, 10, 11, 12, 62 | ;;; 13, and 14. With argument, 3..7 and 12..14. 63 | ;;; 64 | (defcommand "Two Deletes" (p) 65 | "At line 3, delete 3 lines. At line 3+4, delete 5 lines. 66 | With an argument, switch the number deleted." 67 | "At line 3, delete 3 lines. At line 3+4, delete 5 lines. 68 | With an argument, switch the number deleted." 69 | (multiple-value-bind (dnum1 dnum2) 70 | (if p (values 5 3) (values 3 5)) 71 | (let ((point (current-point))) 72 | (move-mark point (window-display-start (current-window))) 73 | (line-offset point 3) 74 | (with-mark ((end point :left-inserting)) 75 | (line-offset end dnum1) 76 | (delete-region (region point end)) 77 | (line-offset point 4) 78 | (line-offset (move-mark end point) dnum2) 79 | (delete-region (region point end)))))) 80 | 81 | 82 | ;;; Given "Setup Tty Buffer", opens two blank lines between 2 and 3, and 83 | ;;; opens four blank lines between 6 and 7, leaving line numbered 13 at 84 | ;;; the bottom. With argument, four lines between 2 and 3, two lines 85 | ;;; between 6 and 7, and line 13 at the bottom of the window. 86 | ;;; 87 | (defcommand "Two Inserts" (p) 88 | "At line 3, open 2 lines. At line 3+2+4, open 4 lines. 89 | With an argument, switch the number opened." 90 | "At line 3, open 2 lines. At line 3+2+4, open 4 lines. 91 | With an argument, switch the number opened." 92 | (multiple-value-bind (onum1 onum2) 93 | (if p (values 4 2) (values 2 4)) 94 | (let ((point (current-point))) 95 | (move-mark point (window-display-start (current-window))) 96 | (line-offset point 3) 97 | (dotimes (i onum1) 98 | (insert-character point #\newline)) 99 | (line-offset point 4) 100 | (dotimes (i onum2) 101 | (insert-character point #\newline))))) 102 | 103 | 104 | ;;; Given "Setup Tty Buffer", deletes lines numbered 3, 4, and 5, and 105 | ;;; opens five lines between lines numbered 9 and 10, leaving line numbered 106 | ;;; 17 on the bottom. With an argument, deletes lines numbered 3, 4, 5, 6, 107 | ;;; and 7, and opens three lines between 11 and 12, creating two blank lines 108 | ;;; at the end of the screen. 109 | ;;; 110 | (defcommand "One Delete One Insert" (p) 111 | "At line 3, delete 3 lines. At line 3+4, open 5 lines. 112 | With an argument, switch the number of lines affected." 113 | "At line 3, delete 3 lines. At line 3+4, open 5 lines. 114 | With an argument, switch the number of lines affected." 115 | (multiple-value-bind (dnum onum) 116 | (if p (values 5 3) (values 3 5)) 117 | (let ((point (current-point))) 118 | (move-mark point (window-display-start (current-window))) 119 | (line-offset point 3) 120 | (with-mark ((end point :left-inserting)) 121 | (line-offset end dnum) 122 | (delete-region (region point end)) 123 | (line-offset point 4) 124 | (dotimes (i onum) 125 | (insert-character point #\newline)))))) 126 | 127 | ;;; Given "Setup Tty Buffer", opens three blank lines between lines numbered 128 | ;;; 2 and 3, and deletes lines numbered 7, 8, 9, 10, and 11, leaving two 129 | ;;; blank lines at the bottom of the window. With an argument, opens five 130 | ;;; blank lines between lines numbered 2 and 3, and deletes lines 7, 8, and 131 | ;;; 9, leaving line 17 at the bottom of the window. 132 | ;;; 133 | (defcommand "One Insert One Delete" (p) 134 | "At line 3, open 3 lines. At line 3+3+4, delete 5 lines. 135 | With an argument, switch the number of lines affected." 136 | "At line 3, open 3 lines. At line 3+3+4, delete 5 lines. 137 | With an argument, switch the number of lines affected." 138 | (multiple-value-bind (onum dnum) 139 | (if p (values 5 3) (values 3 5)) 140 | (let ((point (current-point))) 141 | (move-mark point (window-display-start (current-window))) 142 | (line-offset point 3) 143 | (dotimes (i onum) 144 | (insert-character point #\newline)) 145 | (line-offset point 4) 146 | (with-mark ((end point :left-inserting)) 147 | (line-offset end dnum) 148 | (delete-region (region point end)))))) 149 | 150 | 151 | ;;; This could be thrown away, but I'll leave it here. When I was testing 152 | ;;; the problem of generating EQ screen image lines due to faulty 153 | ;;; COMPUTE-TTY-CHANGES, this was a convenient command to get the editor 154 | ;;; back under control. 155 | ;;; 156 | (defcommand "Fix Screen Image Lines" (p) 157 | "" 158 | "" 159 | (declare (ignore p)) 160 | (let* ((device (hi::device-hunk-device (hi::window-hunk (current-window)))) 161 | (lines (hi::tty-device-lines device)) 162 | (columns (hi::tty-device-columns device)) 163 | (screen-image (hi::tty-device-screen-image device))) 164 | (dotimes (i lines) 165 | (setf (svref screen-image i) (hi::make-si-line columns))))) 166 | -------------------------------------------------------------------------------- /doc/misc/perq-hemlock.log: -------------------------------------------------------------------------------- 1 | /Lisp2/Slisp/Hemlock/perqsite.slisp#1, 23-Mar-85 11:05:16, Edit by Ram 2 | Made wait-for-more use logical-char=. 3 | 4 | /lisp2/slisp/hemlock/echocoms.slisp#1, 22-Mar-85 13:41:10, Edit by Ram 5 | Made "Complete Keyword" and "Help on Parse" pass the parse default into 6 | Complete-File and Ambiguous-Files, respectively. 7 | 8 | /Lisp2/Slisp/Hemlock/echocoms.slisp#1, 22-Mar-85 10:51:09, Edit by Ram 9 | Updated to correspond to new prompting conventions. 10 | 11 | /Lisp2/Slisp/Hemlock/echo.slisp#1, 22-Mar-85 10:21:19, Edit by Ram 12 | Changes to make defaulting work better. *parse-default* is now a string 13 | which we pretend we read when we confirm an empty parse. 14 | *parse-default-string* is now only used in displaying the default, as it 15 | should be. The prompt and help can now be a list of format string and format 16 | arguments. The feature of help being a function is gone. 17 | 18 | /Lisp2/Slisp/Hemlock/echo.slisp#1, 22-Mar-85 08:00:01, Edit by Ram 19 | Made Parse-For-Something specify NIL to Recursive-Edit so that C-G's will 20 | blow away prompts. 21 | 22 | /Lisp2/Slisp/Hemlock/buffer.slisp#1, 22-Mar-85 07:57:49, Edit by Ram 23 | Added the optional Handle-Abort argument to recursive-edit so that we can 24 | have recursive-edits that aren't blown away by C-G's. 25 | 26 | /Lisp2/Slisp/Hemlock/spellcoms.slisp#1, 22-Mar-85 07:35:01, Edit by Ram 27 | Made Sub-Correct-Last-Misspelled-Word delete the marks pointing to misspelled 28 | words when it pops them off the ring. 29 | 30 | /lisp2/slisp/hemlock/syntax.slisp#1, 18-Mar-85 07:20:53, Edit by Ram 31 | Fixed problem with the old value not being saved if a shadow-attribute was 32 | dowe for a mode that is currently active. 33 | 34 | /lisp2/slisp/hemlock/defsyn.slisp#1, 14-Mar-85 09:42:53, Edit by Ram 35 | Made #\. be a word delimiter by default. For old time's sake, it is not 36 | a delimiter in "Fundamental" mode. 37 | 38 | /Lisp2/Slisp/Hemlock/filecoms.slisp#1, 13-Mar-85 00:25:19, Edit by Ram 39 | Changed write-da-file not to compare write dates if the file desn't exist. 40 | 41 | /Lisp2/Slisp/Hemlock/perqsite.slisp#1, 13-Mar-85 00:15:31, Edit by Ram 42 | Changed emergency message stuff to divide the message size by 8. 43 | 44 | /Lisp2/Slisp/Hemlock/htext2.slisp#1, 13-Mar-85 00:07:13, Edit by Ram 45 | Changed %set-next-character to use the body of Modifying-Buffer. Made 46 | string-to-region give the region a disembodied buffer count. 47 | 48 | /Lisp2/Slisp/Hemlock/htext3.slisp#1, 12-Mar-85 23:53:57, Edit by Ram 49 | Changed everyone to use the body of modifying-buffer. 50 | 51 | /Lisp2/Slisp/Hemlock/htext1.slisp#1, 12-Mar-85 23:45:51, Edit by Ram 52 | Made Modifying-Buffer have a body and wrap a without-interrupts around the 53 | body. Changed %set-line-string to run within the body of modifying-buffer. 54 | 55 | /Lisp2/Slisp/Hemlock/echocoms.slisp#1, 12-Mar-85 23:28:40, Edit by Ram 56 | Made "Confirm Parse" push the input before calling the confirm function so 57 | that if it gets an error, you don't have to type it again. Also changed it 58 | to directly return the default if there is empty input, rather than calling 59 | the confirm function on the default string. It used to be this way, and I 60 | changed it, but don't remember why. 61 | 62 | /Lisp2/Slisp/Hemlock/group.slisp#1, 12-Mar-85 23:10:43, Edit by Ram 63 | Made group-read-file go to the beginning of the buffer, which is useful in 64 | the case where the file was already read. 65 | 66 | /Lisp2/Slisp/Hemlock/lispbuf.slisp#1, 12-Mar-85 22:58:03, Edit by Ram 67 | Made "Compile File" use buffer-default-pathname to get defaults for the 68 | prompt. Added "Compile Group" command. 69 | 70 | /lisp2/slisp/hemlock/kbdmac.slisp#1, 09-Mar-85 20:53:33, Edit by Ram 71 | Made default-kbdmac-transform bind *invoke-hook* so that recursive edits 72 | don't try do clever stuff. 73 | 74 | /lisp2/slisp/hemlock/perqsite.slisp#1, 09-Mar-85 14:16:41, Edit by Ram 75 | Changed editor-input stream to use new stream representation. Moved 76 | Input-Waiting here from Streams, changed definition to return T or NIL 77 | instead of number of chars. Made Wait-For-More not unread the character if 78 | it is rubout. Made level-1-abort handler clear input. 79 | 80 | /lisp2/slisp/hemlock/streams.slisp#1, 09-Mar-85 14:59:02, Edit by Ram 81 | Changed to use new stream representation. 82 | 83 | /lisp2/slisp/hemlock/pane-stream.slisp#1, 09-Mar-85 14:51:25, Edit by Ram 84 | Changed to use new stream representation. 85 | 86 | /lisp2/slisp/hemlock/lispmode.slisp#1, 05-Mar-85 11:59:15, Edit by Ram 87 | Changed the "Defindent" command to go to the beginning of the line before 88 | doing the backward-up-list. This means that we always find the form 89 | controlling indentation for the current line, rather than the enclosing form. 90 | Do a "Indent For Lisp" after we redefine the indentation, since it presumably 91 | changed. 92 | 93 | /lisp2/slisp/hemlock/spell-corr.slisp#1, 05-Mar-85 11:39:19, Edit by Ram 94 | Fixed everyone to use gr-call. Made Correct-Spelling call 95 | maybe-read-spell-dictionary, rather than trying to look at 96 | *spell-opeining-return*. 97 | 98 | /lisp2/slisp/hemlock/spell-augment.slisp#1, 05-Mar-85 11:53:04, Edit by Ram 99 | Fixed everyone to use gr-call and friends. 100 | 101 | /Lisp2/Slisp/Hemlock/command.slisp#1, 21-Feb-85 00:56:52, Edit by Ram 102 | Edited back in change to "Scroll Next Window ..." commands to make them 103 | complain if there is only one window. 104 | 105 | /Lisp2/Slisp/Hemlock/filecoms.slisp#1, 21-Feb-85 00:48:00, Edit by Ram 106 | Edited back in changes: 107 | Make "Backup File" message the file written. 108 | Make Previous-Buffer return any buffer other than the current buffer 109 | and the echo area buffer it there is nothing good in the history. 110 | 111 | /Lisp2/Slisp/Hemlock/bindings.slisp#1, 21-Feb-85 00:30:48, Edit by Ram 112 | Removed spurious binding of #\' to "Check Word Spelling". 113 | 114 | /Lisp2/Boot/Hemlock/spellcoms.slisp#1, 05-Feb-85 13:58:54, Edit by Ram 115 | Added call to Region-To-String in "Add Word to Spelling Dictionary" so that 116 | it worked. 117 | 118 | /Lisp2/Boot/Hemlock/fill.slisp#1, 31-Jan-85 12:09:01, Edit by Ram 119 | Made "Set Fill Prefix" and "Set Fill Column" define a buffer local variable 120 | so that the values are buffer local. 121 | 122 | /Lisp2/Boot/Hemlock/fill.slisp#1, 26-Jan-85 17:19:57, Edit by Ram 123 | Made / be a paragraph delimiter. 124 | 125 | /Lisp2/Boot/Hemlock/search2.slisp#1, 26-Jan-85 17:07:37, Edit by Ram 126 | Fixed the reclaim-function for set search patterns to reclaim the set instead 127 | of the search-pattern structure. 128 | 129 | /Lisp2/Boot/Hemlock/group.slisp#1, 25-Jan-85 22:07:15, Edit by Ram 130 | Changed the way Group-Read-File works. We always use "Find File" to read in 131 | the file, but if "Group Find File" is false, and we created a new buffer, we 132 | rename the buffer to "Group Search", nuking any old buffer of that name. If 133 | we are in the "Group Search" buffer when we finish, we nuke it and go to the 134 | previous buffer. 135 | 136 | /Lisp2/Boot/Hemlock/macros.slisp#1, 25-Jan-85 22:35:26, Edit by Ram 137 | Fixed Hlet so that it worked. Evidently nobody had used it before. 138 | 139 | /Lisp2/Boot/Hemlock/filecoms.slisp#1, 25-Jan-85 23:26:35, Edit by Ram 140 | Made "Log Change" merge the buffer pathname defaults into the log file name. 141 | Added the feature that the location for the point in the change log entry 142 | template can be specified by placing a "@" in the template. 143 | 144 | /Lisp2/Boot/Hemlock/search2.slisp#1, 25-Jan-85 23:23:35, Edit by Ram 145 | Fixed various one-off errors in the end args being passed to position and 146 | %sp-find-character-with-attribute. 147 | --------------------------------------------------------------------------------