diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b711c59504fe373e7369efa11cdb43ee5c71ebed --- /dev/null +++ b/clx/defsystem.lisp @@ -0,0 +1,603 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; -*- + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +;;; #+ features used in this file +;;; ansi-common-lisp +;;; lispm +;;; genera +;;; lucid +;;; lcl3.0 +;;; apollo +;;; kcl +;;; ibcl +;;; excl + +#-ansi-common-lisp +(lisp:in-package :xlib :use '(:lisp)) + +#+ansi-common-lisp +(common-lisp:in-package :common-lisp-user) + +#+ansi-common-lisp +(common-lisp:defpackage xlib + (:use common-lisp) + (:size 3000) + #+Genera + (:import-from + (system + arglist downward-funarg array-register) + (zwei + indentation)) + (:export + *version* access-control access-error access-hosts + activate-screen-saver add-access-host add-resource add-to-save-set + alist alloc-color alloc-color-cells alloc-color-planes alloc-error + allow-events angle arc-seq array-index atom-error atom-name + bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p + bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image + boole-constant boolean card16 card29 card32 card8 + card8->char change-active-pointer-grab change-keyboard-control + change-keyboard-mapping change-pointer-control change-property + char->card8 char-ascent char-attributes char-descent + char-left-bearing char-right-bearing char-width character->keysyms + character-in-map-p circulate-window-down circulate-window-up clear-area + close-display close-down-mode close-font closed-display color + color-blue color-green color-p color-red color-rgb colormap + colormap-display colormap-equal colormap-error colormap-id + colormap-p colormap-visual-info connection-failure convert-selection + copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components + copy-image copy-plane create-colormap create-cursor + create-gcontext create-glyph-cursor create-image create-pixmap + create-window cursor cursor-display cursor-equal cursor-error + cursor-id cursor-p cut-buffer declare-event decode-core-error + default-error-handler default-keysym-index default-keysym-translate + define-error define-extension define-gcontext-accessor + define-keysym define-keysym-set delete-property delete-resource + destroy-subwindows destroy-window device-busy device-event-mask + device-event-mask-class discard-current-event discard-font-info display + display-after-function display-authorization-data display-authorization-name + display-bitmap-format display-byte-order display-default-screen + display-display display-error-handler display-finish-output + display-force-output display-host display-image-lsb-first-p + display-invoke-after-function display-keycode-range display-max-keycode + display-max-request-length display-min-keycode display-motion-buffer-size + display-nscreens display-p display-pixmap-formats display-plist + display-protocol-major-version display-protocol-minor-version + display-protocol-version display-release-number + display-report-asynchronous-errors display-resource-id-base + display-resource-id-mask display-roots display-vendor + display-vendor-name display-xdefaults display-xid draw-arc + draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph + draw-image-glyphs draw-line draw-lines draw-point draw-points + draw-rectangle draw-rectangles draw-segments drawable + drawable-border-width drawable-depth drawable-display drawable-equal + drawable-error drawable-height drawable-id drawable-p + drawable-plist drawable-root drawable-width drawable-x drawable-y + error-key event-case event-cond event-handler event-key + event-listen event-mask event-mask-class extension-opcode + find-atom font font-all-chars-exist-p font-ascent + font-default-char font-descent font-direction font-display + font-equal font-error font-id font-max-byte1 font-max-byte2 + font-max-char font-min-byte1 font-min-byte2 font-min-char + font-name font-p font-path font-plist font-properties + font-property fontable force-gcontext-changes free-colormap + free-colors free-cursor free-gcontext free-pixmap gcontext + gcontext-arc-mode gcontext-background gcontext-cap-style + gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x + gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display + gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule + gcontext-fill-style gcontext-font gcontext-foreground gcontext-function + gcontext-id gcontext-join-style gcontext-key gcontext-line-style + gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist + gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x + gcontext-ts-y get-external-event-code get-image get-property + get-raw-image get-resource get-search-resource get-search-table + get-standard-colormap get-wm-class global-pointer-position grab-button + grab-key grab-keyboard grab-pointer grab-server grab-status + icon-sizes iconify-window id-choice-error illegal-request-error + image image-blue-mask image-depth image-green-mask image-height + image-name image-pixmap image-plist image-red-mask image-width + image-x image-x-hot image-x-p image-xy image-xy-bitmap-list + image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p + image-z-pixarray implementation-error input-focus install-colormap + installed-colormaps int16 int32 int8 intern-atom invalid-font + keyboard-control keyboard-mapping keycode->character keycode->keysym + keysym keysym->character keysym->keycodes keysym-in-map-p + keysym-set kill-client kill-temporary-clients length-error + list-extensions list-font-names list-fonts list-properties + lookup-color lookup-error make-color make-event-handlers + make-event-keys make-event-mask make-resource-database make-state-keys + make-state-mask make-wm-hints make-wm-size-hints map-resource + map-subwindows map-window mapping-notify mask16 mask32 + match-error max-char-ascent max-char-attributes max-char-descent + max-char-left-bearing max-char-right-bearing max-char-width + merge-resources min-char-ascent min-char-attributes min-char-descent + min-char-left-bearing min-char-right-bearing min-char-width + missing-parameter modifier-key modifier-mapping modifier-mask + motion-events name-error no-operation open-display open-font + pixarray pixel pixmap pixmap-display pixmap-equal + pixmap-error pixmap-format pixmap-format-bits-per-pixel + pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad + pixmap-id pixmap-p pixmap-plist point-seq pointer-control + pointer-event-mask pointer-event-mask-class pointer-mapping + pointer-position process-event put-image put-raw-image + query-best-cursor query-best-stipple query-best-tile query-colors + query-extension query-keymap query-pointer query-tree queue-event + read-bitmap-file read-resources recolor-cursor rect-seq + remove-access-host remove-from-save-set reparent-window repeat-seq + reply-length-error reply-timeout request-error reset-screen-saver + resource-database resource-database-timestamp resource-error + resource-id resource-key rgb-colormaps rgb-val root-resources + rotate-cut-buffers rotate-properties screen screen-backing-stores + screen-black-pixel screen-default-colormap screen-depths + screen-event-mask-at-open screen-height screen-height-in-millimeters + screen-max-installed-maps screen-min-installed-maps screen-p + screen-plist screen-root screen-root-depth screen-root-visual + screen-root-visual-info screen-save-unders-p screen-saver + screen-white-pixel screen-width screen-width-in-millimeters seg-seq + selection-owner send-event sequence-error set-access-control + set-close-down-mode set-input-focus set-modifier-mapping + set-pointer-mapping set-screen-saver set-selection-owner + set-standard-colormap set-standard-properties set-wm-class + set-wm-properties set-wm-resources state-keysym-p state-mask-key + store-color store-colors stringable text-extents text-width + timestamp transient-for translate-coordinates translate-default + translation-function undefine-keysym unexpected-reply + ungrab-button ungrab-key ungrab-keyboard ungrab-pointer + ungrab-server uninstall-colormap unknown-error unmap-subwindows + unmap-window value-error visual-info visual-info-bits-per-rgb + visual-info-blue-mask visual-info-class visual-info-colormap-entries + visual-info-display visual-info-green-mask visual-info-id visual-info-p + visual-info-plist visual-info-red-mask warp-pointer + warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside + win-gravity window window-all-event-masks window-background + window-backing-pixel window-backing-planes window-backing-store + window-bit-gravity window-border window-class window-colormap + window-colormap-installed-p window-cursor window-display + window-do-not-propagate-mask window-equal window-error + window-event-mask window-gravity window-id window-map-state + window-override-redirect window-p window-plist window-priority + window-save-under window-visual window-visual-info with-display + with-event-queue with-gcontext with-server-grabbed with-state + withdraw-window wm-client-machine wm-colormap-windows wm-command + wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap + wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y + wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group + wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources + wm-size-hints wm-size-hints-base-height wm-size-hints-base-width + wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect + wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect + wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p + wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p + wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity + wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file + write-resources xatom)) + +#+ansi-common-lisp +(common-lisp:in-package :xlib) + +#-lispm +(export '( + compile-clx + load-clx)) + +#+excl (error "Use excldefsys") + + +;;;; Lisp Machines + +;;; Lisp machines have their own defsystems, so we use them to define +;;; the CLX load. + +#+(and lispm (not genera)) +(global:defsystem CLX + (:pathname-default "clx:clx;") + (:patchable "clx:patch;" clx-ti) + (:initial-status :experimental) + + (:module depdefs "depdefs") + (:module clx "clx") + (:module dependent "dependent") + (:module macros "macros") + (:module bufmac "bufmac") + (:module buffer "buffer") + (:module display "display") + (:module gcontext "gcontext") + (:module requests "requests") + (:module input "input") + (:module fonts "fonts") + (:module graphics "graphics") + (:module text "text") + (:module attributes "attributes") + (:module translate "translate") + (:module keysyms "keysyms") + (:module manager "manager") + (:module image "image") + (:module resource "resource") + (:module doc "doc") + + (:compile-load depdefs) + (:compile-load clx + (:fasload depdefs)) + (:compile-load dependent + (:fasload depdefs clx)) + ;; Macros only needed for compilation + (:skip :compile-load macros + (:fasload depdefs clx dependent)) + ;; Bufmac only needed for compilation + (:skip :compile-load bufmac + (:fasload depdefs clx dependent macros)) + (:compile-load buffer + (:fasload depdefs clx dependent macros bufmac)) + (:compile-load display + (:fasload depdefs clx dependent macros bufmac buffer)) + (:compile-load gcontext + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load input + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load requests + (:fasload depdefs clx dependent macros bufmac buffer display input)) + (:compile-load fonts + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load graphics + (:fasload depdefs clx dependent macros fonts bufmac buffer display fonts)) + (:compile-load text + (:fasload depdefs clx dependent macros fonts bufmac buffer display gcontext fonts)) + (:compile-load-init attributes + (dependent) ;<- There may be other modules needed here. + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load translate + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load keysyms + (:fasload depdefs clx dependent macros bufmac buffer display translate)) + (:compile-load manager + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load image + (:fasload depdefs clx dependent macros bufmac buffer display)) + (:compile-load resource) + (:auxiliary doc) + ) + + +#+Genera +(scl:defsystem CLX + (:default-pathname "SYS:X11;CLX;" + :default-package "XLIB" + :pretty-name "CLX" + :maintaining-sites (:scrc) + :distribute-sources t + :distribute-binaries t + :source-category :basic) + (:module doc ("doc") + (:type :lisp-example)) + (:module depdefs ("depdefs" "generalock")) + (:module clx ("clx") + (:uses-definitions-from depdefs)) + (:module dependent ("dependent") + (:uses-definitions-from clx)) + (:module macros ("macros") + (:uses-definitions-from dependent)) + (:module bufmac ("bufmac") + (:uses-definitions-from dependent macros)) + (:module buffer ("buffer") + (:uses-definitions-from dependent macros bufmac)) + (:module display ("display") + (:uses-definitions-from dependent macros bufmac buffer)) + (:module gcontext ("gcontext") + (:uses-definitions-from dependent macros bufmac display)) + (:module input ("input") + (:uses-definitions-from dependent macros bufmac display)) + (:module requests ("requests") + (:uses-definitions-from dependent macros bufmac display input)) + (:module fonts ("fonts") + (:uses-definitions-from dependent macros bufmac display)) + (:module graphics ("graphics") + (:uses-definitions-from dependent macros bufmac fonts)) + (:module text ("text") + (:uses-definitions-from dependent macros bufmac gcontext fonts)) + (:module attributes ("attributes") + (:uses-definitions-from dependent macros bufmac display)) + (:module translate ("translate") + (:uses-definitions-from dependent macros bufmac display)) + (:module keysyms ("keysyms") + (:uses-definitions-from translate)) + (:module manager ("manager") + (:uses-definitions-from dependent macros bufmac display)) + (:module image ("image") + (:uses-definitions-from dependent macros bufmac display)) + (:module resource ("resource")) + ) + + +;;;; Non Lisp Machines + +#+lucid +(defvar *foreign-libraries* '("-lc")) ; '("-lresolv" "-lc") for some sites + +#+lucid +(defun clx-foreign-files (binary-path) + + ;; apply a patch to 2.0 systems + #+(and (not lcl3.0) (or mc68000 mc68020)) + (load (merge-pathnames "make-sequence-patch" binary-path)) + + ;; Link lisp to the C function connect_to_server + #+(and apollo (not lcl3.0)) + (lucid::define-foreign-function '(xlib::connect-to-server "connect_to_server") + '((:val host :string) + (:val display :integer32)) + :integer32) + #+(and (not apollo) (not lcl3.0)) + (lucid::define-c-function xlib::connect-to-server + (host display) + :result-type :integer) + #+lcl3.0 + (lucid::def-foreign-function (xlib::connect-to-server + (:language :c) + (:return-type :signed-32bit)) + (host :simple-string) (display :signed-32bit)) + (unintern 'display) + + ;; Load the definition of connect_to_server + #+apollo + (lucid::load-foreign-file (merge-pathnames "socket" binary-path) + :preserve-pathname t) + #-apollo + (lucid::load-foreign-files (list (merge-pathnames "socket.o" binary-path)) + *foreign-libraries*)) + + +;; socket interface for kcl and ibcl +;; defines the function (open-socket-stream host display) +;; +;; You must first compile file socket.c +#+(or kcl ibcl) +(defun kcl-socket-init (binary-path) + (let ((sockcl (namestring (merge-pathnames "sockcl.o" binary-path))) + (socket (namestring (merge-pathnames "socket.o" binary-path)))) + (si:faslink sockcl (format nil "~a -lc" socket)) + )) + + +;;;; Compile CLX + +;;; COMPILE-CLX compiles the lisp source files and loads the binaries. +;;; It goes to some trouble to let the source files be in one directory +;;; and the binary files in another. Thus the same set of sources can +;;; be used for different machines and/or lisp systems. It also allows +;;; you to supply explicit extensions, so source files do not have to +;;; be renamed to fit into the naming conventions of an implementation. + +;;; For example, +;;; (compile-clx "*.lisp" "machine/") +;;; compiles source files from the connected directory and puts them +;;; into the "machine" subdirectory. You can then load CLX out of the +;;; machine directory. + +;;; The code has no knowledge of the source file types (eg, ".l" or +;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin"). Calling +;;; compile-file and load with a file type of NIL usually sorts things +;;; out correctly, but you may have to explicitly give the source and +;;; binary file types. + +;;; An attempt at compiling the C language sources is also made, +;;; but you may have to set different compiler switches +;;; should be. If it doesn't do the right thing, then do +;;; (compile-clx "" "" :compile-c NIL) +;;; to prevent the compilation. + +;;; compilation notes +;;; lucid2.0/hp9000 +;;; must uudecode the file make-sequence-patch.uu + +#-lispm +(defun compile-clx (&optional + (source-pathname-defaults "") + (binary-pathname-defaults "") + &key + (compile-c t)) + + ;; The pathname-defaults above might only be strings, so coerce them + ;; to pathnames. Build a default binary path with every component + ;; of the source except the file type. This should prevent + ;; (compile-clx "*.lisp") from destroying source files. + (let* ((source-path (pathname source-pathname-defaults)) + (path (make-pathname + :host (pathname-host source-path) + :device (pathname-device source-path) + :directory (pathname-directory source-path) + :name (pathname-name source-path) + :type nil + :version (pathname-version source-path))) + (binary-path (merge-pathnames binary-pathname-defaults + path))) + + ;; Make sure source-path and binary-path file types are distinct so + ;; we don't accidently overwrite the source files. NIL should be an + ;; ok type, but anything else spells trouble. + (if (and (equal (pathname-type source-path) + (pathname-type binary-path)) + (not (null (pathname-type binary-path)))) + (error "Source and binary pathname defaults have same type ~s ~s" + source-path binary-path)) + + (format t ";;; Default paths: ~s ~s~%" source-path binary-path) + + ;; In lucid make sure we're using the compiler in production mode. + #+lcl3.0 + (progn + #-pqc + (cerror "Go ahead anyway." + "Lucid's production mode compiler must be loaded to compile CLX.") + (proclaim '(optimize (speed 3) + (safety 1) + (space 0) + (compilation-speed 0)))) + + (flet ((compile-and-load (filename) + (let ((source (merge-pathnames filename source-path)) + (binary (merge-pathnames filename binary-path))) + ;; If the source and binary pathnames are the same, + ;; then don't supply an output file just to be sure + ;; compile-file defaults correctly. + #+(or kcl ibcl) (load source) + (if (equal source binary) + (compile-file source) + (compile-file source :output-file binary)) + (load binary)))) + + ;; Now compile and load all the files. + ;; Defer compiler warnings until everything's compiled, if possible. + (#.(if (fboundp 'with-compilation-unit) + 'with-compilation-unit + #+lcl3.0 'lucid::with-deferred-warnings + #-lcl3.0 'progn) + () + + #+lucid + (progn + (when compile-c ; compile the C files + #+(and (not lcl3.0) (or mc68000 mc68020)) + (progn ; sequence patch + (format t "You may need to uudecode ms-patch.uu and copy~%") + (format t "the result to the binary directory.~%") + (format t "You also must rename the file to have the canonical~%") + (format t "binary file type in order for lisp to realize it's a~%") + (format t "binary file.~%")) + ;; compile socket.c + (let* ((src (merge-pathnames "socket.c" source-path)) + (obj (merge-pathnames "socket.o" binary-path)) + (args (list "-c" (namestring src) + "-o" (namestring obj) + "-DUNIXCONN"))) + (format t ";;; cc~{ ~a~}~%" args) + (multiple-value-bind (iostream estream exitstatus pid) + ;; in 2.0, run-program is exported from system: + ;; in 3.0, run-program is exported from lcl: + ;; system inheirits lcl + (system::run-program "cc" :arguments args) + (declare (ignore iostream estream pid)) + (if (/= 0 exitstatus) + (error "Exit status of socket.c compile is ~d" exitstatus))))) + (format t ";;; Loading foreign files~%") + (clx-foreign-files binary-path)) + + #+(or kcl ibcl) + (progn + (when compile-c ; compile the C files + (let* ((src (merge-pathnames "socket.c" source-path)) + (obj (merge-pathnames "socket.o" binary-path)) + (arg (format nil "cc -c ~a -o ~a -DUNIXCONN" + (namestring src) + (namestring obj)))) + (format t ";;; ~a~%" arg) + (if (/= 0 (system arg)) + (error "bad exit status for ~s" src)))) + ;; compile the lisp interface to the c code + (let ((src (merge-pathnames "sockcl" source-path)) + (obj (merge-pathnames "sockcl.o" binary-path))) + (compile-file src :output-file obj)) + (kcl-socket-init binary-path)) + + (compile-and-load "depdefs") + (compile-and-load "clx") + (compile-and-load "dependent") + (compile-and-load "macros") ; these are just macros + (compile-and-load "bufmac") ; these are just macros + (compile-and-load "buffer") + (compile-and-load "display") + (compile-and-load "gcontext") + (compile-and-load "input") + (compile-and-load "requests") + (compile-and-load "fonts") + (compile-and-load "graphics") + (compile-and-load "text") + (compile-and-load "attributes") + (compile-and-load "translate") + (compile-and-load "keysyms") + (compile-and-load "manager") + (compile-and-load "image") + (compile-and-load "resource") + )))) + + +;;;; Load CLX + +;;; This procedure loads the binaries for CLX. All of the binaries +;;; should be in the same directory, so setting the default pathname +;;; should point load to the right place. + +;;; You should have a module definition somewhere so the require/provide +;;; mechanism can avoid reloading CLX. In an ideal world, somebody would +;;; just put +;;; (REQUIRE 'CLX) +;;; in their file (some implementations don't have a central registry for +;;; modules, so a pathname needs to be supplied). + +;;; The REQUIRE should find a file that does +;;; (IN-PACKAGE 'XLIB :USE '(LISP)) +;;; (PROVIDE 'CLX) +;;; (LOAD <clx-defsystem-file>) +;;; (LOAD-CLX <binary-specific-clx-directory>) + +#-lispm +(defun load-clx (&optional (binary-pathname-defaults "") + &key (macros-p nil)) + + (let* ((source-path (pathname "")) + (path (make-pathname + :host (pathname-host source-path) + :device (pathname-device source-path) + :directory (pathname-directory source-path) + :name (pathname-name source-path) + :type nil + :version (pathname-version source-path))) + (binary-path (merge-pathnames binary-pathname-defaults + path))) + + (flet ((load-binary (filename) + (let ((binary (merge-pathnames filename binary-path))) + (load binary)))) + + #+lucid + (clx-foreign-files binary-path) + + #+(or kcl ibcl) + (kcl-socket-init binary-path) + + (load-binary "depdefs") + (load-binary "clx") + (load-binary "dependent") + (when macros-p + (load-binary "macros") + (load-binary "bufmac")) + (load-binary "buffer") + (load-binary "display") + (load-binary "gcontext") + (load-binary "input") + (load-binary "requests") + (load-binary "fonts") + (load-binary "graphics") + (load-binary "text") + (load-binary "attributes") + (load-binary "translate") + (load-binary "keysyms") + (load-binary "manager") + (load-binary "image") + (load-binary "resource") + ))) diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp new file mode 100644 index 0000000000000000000000000000000000000000..1f86c22d6b607dfc886354099f65f2abbfd47083 --- /dev/null +++ b/clx/depdefs.lisp @@ -0,0 +1,654 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;; This file contains some of the system dependent code for CLX + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +;;;------------------------------------------------------------------------- +;;; Declarations +;;;------------------------------------------------------------------------- + +;;; fix a bug in kcl's RATIONAL... +;;; redefine both the function and the type. + +#+(or kcl ibcl) +(shadow 'rational) + +#+(or kcl ibcl) +(progn + (defun rational (x) + (if (rationalp x) + x + (lisp:rational x))) + (deftype rational () 'lisp:rational)) + +;;; DECLAIM + +#-ansi-common-lisp +(defmacro declaim (&rest decl-specs) + (if (cdr decl-specs) + `(progn + ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec)) + decl-specs)) + `(proclaim ',(car decl-specs)))) + +;;; VALUES value1 value2 ... -- Documents the values returned by the function. + +#-lispm +(declaim (declaration values)) + +;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides +;;; the documentation that might get generated by the real arglist of the +;;; function. + +#+lispm +(import '(sys:arglist)) + +#+lcl3.0 +(import '(lcl:arglist)) + +#-(or lispm lcl3.0) +(declaim (declaration arglist)) + +;;; DOWNWARD-FUNARG name1 name2 ... -- Tells callers of this function that +;;; closures passed in as the argument named by name can be consed on the +;;; stack, as they have dynamic extent. In Genera keyword args can't be named +;;; this way. Instead use * to specify all functional args have dynamic +;;; extent. + +#+lispm +(import '(sys:downward-funarg)) + +#-lispm +(declaim (declaration downward-funarg)) + +;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has +;;; dynamic extent and therefore can be kept on the stack and not copied to +;;; the heap, even though the value is passed out of the function. + +#+lcl3.0 +(import '(lcl:dynamic-extent)) + +#-(or ansi-common-lisp lcl3.0) +(declaim (declaration dynamic-extent)) + +;;; ARRAY-REGISTER var1 var2 ... -- The variables mentioned are locals (not +;;; args) that hold vectors. + +#+Genera +(import '(sys:array-register)) + +#-Genera +(declaim (declaration array-register)) + +;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to +;;; indent calls to the function or macro containing the declaration. + +#+genera +(import '(zwei:indentation)) + +#-genera +(declaim (declaration indentation)) + +;;;------------------------------------------------------------------------- +;;; Declaration macros +;;;------------------------------------------------------------------------- + +;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local +;;; and then does a type declaration and array register declaration +(defmacro with-vector ((var type) &body body) + `(let ((,var ,var)) + (declare (type ,type ,var) + (array-register ,var)) + ,@body)) + +;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for +;;; Meta-. + +#+lispm +(defmacro within-definition ((name type) &body body) + `(zl:local-declare + ((sys:function-parent ,name ,type)) + (sys:record-source-file-name ',name ',type) + ,@body)) + +#-lispm +(defmacro within-definition ((name type) &body body) + (declare (ignore name type)) + `(progn ,@body)) + + +;;;------------------------------------------------------------------------- +;;; CLX can maintain a mapping from X server ID's to local data types. If +;;; one takes the view that CLX objects will be instance variables of +;;; objects at the next higher level, then PROCESS-EVENT will typically map +;;; from resource-id to higher-level object. In that case, the lower-level +;;; CLX mapping will almost never be used (except in rare cases like +;;; query-tree), and only serve to consume space (which is difficult to +;;; GC), in which case always-consing versions of the make-<mumble>s will +;;; be better. Even when maps are maintained, it isn't clear they are +;;; useful for much beyond xatoms and windows (since almost nothing else +;;; ever comes back in events). +;;;-------------------------------------------------------------------------- +(defconstant *clx-cached-types* + '( drawable + window + pixmap +; gcontext + cursor + colormap + font)) + +(defmacro resource-id-map-test () + #+excl '#'equal + #-excl '#'eql) ; (eq fixnum fixnum) is not guaranteed. + +(defmacro keysym->character-map-test () + #+excl '#'equal + #-excl '#'eql) + +;;; You must define this to match the real byte order. It is used by +;;; overlapping array and image code. + +#+(or lispm vax little-endian) +(eval-when (eval compile load) + (pushnew :clx-little-endian *features*)) + +#+lcl3.0 +(eval-when (compile eval load) + (ecase lucid::machine-endian + (:big) + (:little (pushnew :clx-little-endian *features*)))) + +;;; Steele's Common-Lisp states: "It is an error if the array specified +;;; as the :displaced-to argument does not have the same :element-type +;;; as the array being created" If this is the case on your lisp, then +;;; leave the overlapping-arrays feature turned off. Lisp machines +;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays +;;; with different element types to overlap. CLX will take advantage of +;;; this to do fast array packing/unpacking when the overlapping-arrays +;;; feature is enabled. + +#+(and clx-little-endian lispm) +(eval-when (eval compile load) + (pushnew :clx-overlapping-arrays *features*)) + +#+(and clx-overlapping-arrays genera) +(progn +(deftype overlap16 () '(unsigned-byte 16)) +(deftype overlap32 () '(signed-byte 32)) +) + +#+(and clx-overlapping-arrays (or explorer lambda cadr)) +(progn +(deftype overlap16 () '(unsigned-byte 16)) +(deftype overlap32 () '(unsigned-byte 32)) +) + +(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*))) + +#+clx-overlapping-arrays +(progn +(deftype buffer-words () `(vector overlap16)) +(deftype buffer-longs () `(vector overlap32)) +) + +;;; This defines a type which is a subtype of the integers. +;;; This type is used to describe all variables that can be array indices. +;;; It is here because it is used below. +;;; This is inclusive because start/end can be 1 past the end. +(deftype array-index () `(integer 0 ,array-dimension-limit)) + + +;; this is the best place to define these? + +#-Genera +(progn + +(defun make-index-typed (form) + (if (constantp form) form `(the array-index ,form))) + +(defun make-index-op (operator args) + `(the array-index + (values + ,(case (length args) + (0 `(,operator)) + (1 `(,operator + ,(make-index-typed (first args)))) + (2 `(,operator + ,(make-index-typed (first args)) + ,(make-index-typed (second args)))) + (otherwise + `(,operator + ,(make-index-op operator (subseq args 0 (1- (length args)))) + ,(make-index-typed (first (last args))))))))) + +(defmacro index+ (&rest numbers) (make-index-op '+ numbers)) +(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers)) +(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers)) +(defmacro index- (&rest numbers) (make-index-op '- numbers)) +(defmacro index* (&rest numbers) (make-index-op '* numbers)) + +(defmacro index1+ (number) (make-index-op '1+ (list number))) +(defmacro index1- (number) (make-index-op '1- (list number))) + +(defmacro index-incf (place &optional (delta 1)) + (make-index-op 'incf (list place delta))) +(defmacro index-decf (place &optional (delta 1)) + (make-index-op 'decf (list place delta))) + +(defmacro index-min (&rest numbers) (make-index-op 'min numbers)) +(defmacro index-max (&rest numbers) (make-index-op 'max numbers)) + +(defmacro index-floor (number divisor) + (make-index-op 'floor (list number divisor))) +(defmacro index-ceiling (number divisor) + (make-index-op 'ceiling (list number divisor))) +(defmacro index-truncate (number divisor) + (make-index-op 'truncate (list number divisor))) + +(defmacro index-mod (number divisor) + (make-index-op 'mod (list number divisor))) + +(defmacro index-ash (number count) + (make-index-op 'ash (list number count))) + +(defmacro index-plusp (number) `(plusp (the array-index ,number))) +(defmacro index-zerop (number) `(zerop (the array-index ,number))) +(defmacro index-evenp (number) `(evenp (the array-index ,number))) +(defmacro index-oddp (number) `(oddp (the array-index ,number))) + +(defmacro index> (&rest numbers) + `(> ,@(mapcar #'make-index-typed numbers))) +(defmacro index= (&rest numbers) + `(= ,@(mapcar #'make-index-typed numbers))) +(defmacro index< (&rest numbers) + `(< ,@(mapcar #'make-index-typed numbers))) +(defmacro index>= (&rest numbers) + `(>= ,@(mapcar #'make-index-typed numbers))) +(defmacro index<= (&rest numbers) + `(<= ,@(mapcar #'make-index-typed numbers))) + +) + +#+Genera +(progn + +(defmacro index+ (&rest numbers) `(+ ,@numbers)) +(defmacro index-logand (&rest numbers) `(logand ,@numbers)) +(defmacro index-logior (&rest numbers) `(logior ,@numbers)) +(defmacro index- (&rest numbers) `(- ,@numbers)) +(defmacro index* (&rest numbers) `(* ,@numbers)) + +(defmacro index1+ (number) `(1+ ,number)) +(defmacro index1- (number) `(1- ,number)) + +(defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta))) +(defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta))) + +(defmacro index-min (&rest numbers) `(min ,@numbers)) +(defmacro index-max (&rest numbers) `(max ,@numbers)) + +(defun positive-power-of-two-p (x) + (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x))))) + +(defmacro index-floor (number divisor) + (cond ((eql divisor 1) number) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,divisor)) + (t `(floor ,number ,divisor)))) + +(defmacro index-ceiling (number divisor) + (cond ((eql divisor 1) number) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling)) + `(si:%fixnum-ceiling ,number ,divisor)) + (t `(ceiling ,number ,divisor)))) + +(defmacro index-truncate (number divisor) + (cond ((eql divisor 1) number) + ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,divisor)) + (t `(truncate ,number ,divisor)))) + +(defmacro index-mod (number divisor) + (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod)) + `(si:%fixnum-mod ,number ,divisor)) + (t `(mod ,number ,divisor)))) + +(defmacro index-ash (number count) + (cond ((eql count 0) number) + ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor)) + `(si:%fixnum-floor ,number ,(expt 2 (- count)))) + ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply)) + `(si:%fixnum-multiply ,number ,(expt 2 count))) + (t `(ash ,number ,count)))) + +(defmacro index-plusp (number) `(plusp ,number)) +(defmacro index-zerop (number) `(zerop ,number)) +(defmacro index-evenp (number) `(evenp ,number)) +(defmacro index-oddp (number) `(oddp ,number)) + +(defmacro index> (&rest numbers) `(> ,@numbers)) +(defmacro index= (&rest numbers) `(= ,@numbers)) +(defmacro index< (&rest numbers) `(< ,@numbers)) +(defmacro index>= (&rest numbers) `(>= ,@numbers)) +(defmacro index<= (&rest numbers) `(<= ,@numbers)) + +) + +;;;; Stuff for BUFFER definition + +(defconstant *replysize* 32.) + +;; used in defstruct initializations to avoid compiler warnings +(defvar *empty-bytes* (make-sequence 'buffer-bytes 0)) +(declaim (type buffer-bytes *empty-bytes*)) +#+clx-overlapping-arrays +(progn +(defvar *empty-words* (make-sequence 'buffer-words 0)) +(declaim (type buffer-words *empty-words*)) +) +#+clx-overlapping-arrays +(progn +(defvar *empty-longs* (make-sequence 'buffer-longs 0)) +(declaim (type buffer-longs *empty-longs*)) +) + +(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal) + (:copier nil) (:predicate nil)) + (size 0 :type array-index) ;Buffer size + ;; Byte (8 bit) input buffer + (ibuf8 *empty-bytes* :type buffer-bytes) + ;; Word (16bit) input buffer + #+clx-overlapping-arrays + (ibuf16 *empty-words* :type buffer-words) + ;; Long (32bit) input buffer + #+clx-overlapping-arrays + (ibuf32 *empty-longs* :type buffer-longs) + (next nil #-explorer :type #-explorer (or null reply-buffer)) + (data-size 0 :type array-index) + ) + +(defconstant *buffer-text16-size* 256) +(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*))) + +;; These are here because. + +(defparameter *xlib-package* (find-package 'xlib)) + +(defun xintern (&rest parts) + (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*)) + +(defparameter *keyword-package* (find-package 'keyword)) + +(defun kintern (name) + (intern (string name) *keyword-package*)) + +;;; Pseudo-class mechanism. + +(defmacro def-clx-class ((name &rest options) &body slots) + (let ((clos-package (or (find-package 'clos) + (find-package 'pcl) + (let ((lisp-pkg (find-package 'lisp))) + (and (find-symbol (string 'defclass) lisp-pkg) + lisp-pkg))))) + (if clos-package + (let ((constructor t) + (constructor-args t) + (include nil) + (print-function nil) + (copier t) + (predicate t)) + (dolist (option options) + (ecase (pop option) + (:constructor + (setf constructor (pop option)) + (setf constructor-args (if (null option) t (pop option)))) + (:include + (setf include (pop option))) + (:print-function + (setf print-function (pop option))) + (:copier + (setf copier (pop option))) + (:predicate + (setf predicate (pop option))))) + (flet ((cintern (&rest symbols) + (intern (apply #'concatenate 'simple-string + (mapcar #'symbol-name symbols)) + *package*)) + (kintern (symbol) + (intern (symbol-name symbol) (find-package 'keyword))) + (closintern (symbol) + (intern (symbol-name symbol) clos-package))) + (when (eq constructor t) + (setf constructor (cintern 'make- name))) + (when (eq copier t) + (setf copier (cintern 'copy- name))) + (when (eq predicate t) + (setf predicate (cintern name '-p))) + (when include + (setf slots (append (get include 'def-clx-class) slots))) + (let* ((n-slots (length slots)) + (slot-names (make-list n-slots)) + (slot-initforms (make-list n-slots)) + (slot-types (make-list n-slots))) + (dotimes (i n-slots) + (let ((slot (elt slots i))) + (setf (elt slot-names i) (pop slot)) + (setf (elt slot-initforms i) (pop slot)) + (setf (elt slot-types i) (getf slot :type t)))) + `(progn + + (eval-when (compile load eval) + (setf (get ',name 'def-clx-class) ',slots)) + + ;; From here down are the system-specific expansions: + + ,(cond (clos-package + `(within-definition (,name def-clx-class) + (,(closintern 'defclass) + ,name ,(and include `(,include)) + (,@(map 'list + #'(lambda (slot-name slot-initform slot-type) + `(,slot-name + :initform ,slot-initform :type ,slot-type + :accessor ,(cintern name '- slot-name) + ,@(when (and constructor + (or (eq constructor-args t) + (member slot-name + constructor-args))) + `(:initarg ,(kintern slot-name))) + )) + slot-names slot-initforms slot-types))) + ,(when constructor + (if (eq constructor-args t) + `(defun ,constructor (&rest args) + (apply #',(closintern 'make-instance) + ',name args)) + `(defun ,constructor ,constructor-args + (,(closintern 'make-instance) ',name + ,@(mapcan #'(lambda (slot-name) + (and (member slot-name slot-names) + `(,(kintern slot-name) ,slot-name))) + constructor-args))))) + ,(when predicate + `(defun ,predicate (object) + (typep object ',name))) + ,(when copier + `(,(closintern 'defmethod) ,copier ((.object. ,name)) + (,(closintern 'with-slots) ,slot-names .object. + (,(closintern 'make-instance) ',name + ,@(mapcan #'(lambda (slot-name) + `(,(kintern slot-name) ,slot-name)) + slot-names))))) + ,(when print-function + `(,(closintern 'defmethod) + ,(closintern 'print-object) + ((object ,name) stream) + (,print-function object stream 0))))) + + #+Genera + (t + `(within-definition (,name def-clx-class) + (flavor:defflavor ,name + (,@(map 'list + #'(lambda (slot-name slot-initform) + `(,slot-name ,slot-initform)) + slot-names slot-initforms)) + ,(and include `(,include)) + :initable-instance-variables + :locatable-instance-variables + :readable-instance-variables + :writable-instance-variables + ,(if constructor + `(:constructor ,constructor + ,(if (eq constructor-args t) + `(&key ,@slot-names) + constructor-args)) + :abstract-flavor)) + ,(when predicate + `(defun ,predicate (object) + (typep object ',name))) + ,(when copier + (error ":COPIER not supported.")) + ,(when print-function + `(flavor:defmethod (sys:print-self ,name) + (stream depth *print-escape*) + (,print-function sys:self stream depth))) + (flavor:compile-flavor-methods ,name)))))))) + `(within-definition (,name def-clx-class) + (defstruct (,name ,@options) + ,@slots))))) + +#+Genera +(progn + (scl:defprop def-clx-class "CLX Class" si:definition-type-name) + (scl:defprop def-clx-class zwei:defselect-function-spec-finder + zwei:definition-function-spec-finder)) + + +;; We need this here so we can define DISPLAY for CLX. +;; +;; This structure is :INCLUDEd in the DISPLAY structure. +;; Overlapping (displaced) arrays are provided for byte +;; half-word and word access on both input and output. +;; +(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil)) + ;; Lock for multi-processing systems + (lock (make-process-lock "CLX Buffer Lock")) + #-excl (output-stream nil :type (or null stream)) + #+excl (output-stream -1 :type fixnum) + ;; Buffer size + (size 0 :type array-index) + (request-number 0 :type (unsigned-byte 16)) + ;; Byte position of start of last request + ;; used for appending requests and error recovery + (last-request nil :type (or null array-index)) + ;; Byte position of start of last flushed request + (last-flushed-request nil :type (or null array-index)) + ;; Current byte offset + (boffset 0 :type array-index) + ;; Byte (8 bit) output buffer + (obuf8 *empty-bytes* :type buffer-bytes) + ;; Word (16bit) output buffer + #+clx-overlapping-arrays + (obuf16 *empty-words* :type buffer-words) + ;; Long (32bit) output buffer + #+clx-overlapping-arrays + (obuf32 *empty-longs* :type buffer-longs) + ;; Holding buffer for 16-bit text + (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0)) + ;; Probably EQ to Output-Stream + #-excl (input-stream nil :type (or null stream)) + #+excl (input-stream -1 :type fixnum) + ;; T when the host connection has gotten errors + (dead nil :type (or null (not null))) + ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited. + (flush-inhibit nil :type (or null (not null))) + + ;; Change these functions when using shared memory buffers to the server + ;; Function to call when writing the buffer + (write-function 'buffer-write-default) + ;; Function to call when flushing the buffer + (force-output-function 'buffer-force-output-default) + ;; Function to call when closing a connection + (close-function 'buffer-close-default) + ;; Function to call when reading the buffer + (input-function 'buffer-read-default) + ;; Function to call to wait for data to be input + (input-wait-function 'buffer-input-wait-default) + ;; Function to call to listen for input data + (listen-function 'buffer-listen-default) + + #+Genera (debug-io nil :type (or null stream)) + ) + +;;----------------------------------------------------------------------------- +;; Printing routines. +;;----------------------------------------------------------------------------- + +#+(and (not ansi-common-lisp) Genera) +(import 'future-common-lisp:print-unreadable-object) + +#-(or ansi-common-lisp Genera) +(defun print-unreadable-object-function (object stream type identity function) + (princ "#<" stream) + (when type + (let ((type (type-of object)) + (pcl-package (find-package 'pcl))) + ;; Handle pcl type-of lossage + (when (and pcl-package + (symbolp type) + (eq (symbol-package type) pcl-package) + (string-equal (symbol-name type) "STD-INSTANCE")) + (setq type + (funcall (intern (symbol-name 'class-name) pcl-package) + (funcall (intern (symbol-name 'class-of) pcl-package) + object)))) + (prin1 type stream))) + (when (and type function) (princ " " stream)) + (when function (funcall function)) + (when (and (or type function) identity) (princ " " stream)) + (when identity (princ "???" stream)) + (princ ">" stream) + nil) + +#-(or ansi-common-lisp Genera) +(defmacro print-unreadable-object + ((object stream &key type identity) &body body) + `(print-unreadable-object-function + ,object ,stream ,type ,identity + ,(and body `#'(lambda () ,@body)))) + + +;;----------------------------------------------------------------------------- +;; Image stuff +;;----------------------------------------------------------------------------- + +(defconstant *image-bit-lsb-first-p* + #+clx-little-endian t + #-clx-little-endian nil) + +(defconstant *image-byte-lsb-first-p* + #+clx-little-endian t + #-clx-little-endian nil) + +(defconstant *image-unit* 32) + +(defconstant *image-pad* 32) diff --git a/clx/dependent.lisp b/clx/dependent.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b8e5a3d752c2a2c5636a1986310e1aaa3870030d --- /dev/null +++ b/clx/dependent.lisp @@ -0,0 +1,3064 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;; This file contains some of the system dependent code for CLX + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +#+lcl3.0 +(import '( + lcl:define-condition + lcl:type-error + lucid::type-error-datum + lucid::type-error-expected-type + sys:underlying-simple-vector)) + +(export '( + char->card8 + card8->char + default-error-handler + #-ansi-common-lisp define-condition)) + +#+explorer +(zwei:define-indentation event-case (1 1)) + +;;; Number of seconds to wait for a reply to a server request +(defparameter *reply-timeout* nil) + +#-(or clx-overlapping-arrays (not clx-little-endian)) +(progn + (defconstant *word-0* 0) + (defconstant *word-1* 1) + + (defconstant *long-0* 0) + (defconstant *long-1* 1) + (defconstant *long-2* 2) + (defconstant *long-3* 3)) + +#-(or clx-overlapping-arrays clx-little-endian) +(progn + (defconstant *word-0* 1) + (defconstant *word-1* 0) + + (defconstant *long-0* 3) + (defconstant *long-1* 2) + (defconstant *long-2* 1) + (defconstant *long-3* 0)) + +;;; Set some compiler-options for often used code + +(eval-when (eval compile load) + +(defconstant *buffer-speed* 3 + "Speed compiler option for buffer code.") +(defconstant *buffer-safety* #+clx-debugging 3 #-clx-debugging 0 + "Safety compiler option for buffer code.") + +(defun declare-bufmac () + `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*)))) + +;;; It's my impression that in lucid there's some way to make a declaration +;;; called fast-entry or something that causes a function to not do some +;;; checking on args. Sadly, we have no lucid manuals here. If such a +;;; declaration is available, it would be a good idea to make it here when +;;; *buffer-speed* is 3 and *buffer-safety* is 0. +(defun declare-buffun () + `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*)))) + +) + +(declaim (inline card8->int8 int8->card8 + card16->int16 int16->card16 + card32->int32 int32->card32)) + +#-Genera +(progn + +(defun card8->int8 (x) + (declare (type card8 x)) + (declare (values int8)) + #.(declare-buffun) + (the int8 (if (logbitp 7 x) + (the int8 (- x #x100)) + x))) + +(defun int8->card8 (x) + (declare (type int8 x)) + (declare (values card8)) + #.(declare-buffun) + (the card8 (ldb (byte 8 0) x))) + +(defun card16->int16 (x) + (declare (type card16 x)) + (declare (values int16)) + #.(declare-buffun) + (the int16 (if (logbitp 15 x) + (the int16 (- x #x10000)) + x))) + +(defun int16->card16 (x) + (declare (type int16 x)) + (declare (values card16)) + #.(declare-buffun) + (the card16 (ldb (byte 16 0) x))) + +(defun card32->int32 (x) + (declare (type card32 x)) + (declare (values int32)) + #.(declare-buffun) + (the int32 (if (logbitp 31 x) + (the int32 (- x #x100000000)) + x))) + +(defun int32->card32 (x) + (declare (type int32 x)) + (declare (values card32)) + #.(declare-buffun) + (the card32 (ldb (byte 32 0) x))) + +) + +#+Genera +(progn + +(defun card8->int8 (x) + (declare lt:(side-effects simple reducible)) + (if (logbitp 7 x) (- x #x100) x)) + +(defun int8->card8 (x) + (declare lt:(side-effects simple reducible)) + (ldb (byte 8 0) x)) + +(defun card16->int16 (x) + (declare lt:(side-effects simple reducible)) + (if (logbitp 15 x) (- x #x10000) x)) + +(defun int16->card16 (x) + (declare lt:(side-effects simple reducible)) + (ldb (byte 16 0) x)) + +(defun card32->int32 (x) + (declare lt:(side-effects simple reducible)) + (sys:%logldb (byte 32 0) x)) + +(defun int32->card32 (x) + (declare lt:(side-effects simple reducible)) + (ldb (byte 32 0) x)) + +) + +(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) + +#-(or Genera lcl3.0) +(progn + +(defun aref-card8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card8)) + #.(declare-buffun) + (the card8 (aref a i))) + +(defun aset-card8 (v a i) + (declare (type card8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a i) v)) + +(defun aref-int8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int8)) + #.(declare-buffun) + (card8->int8 (aref a i))) + +(defun aset-int8 (v a i) + (declare (type int8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a i) (int8->card8 v))) + +) + +#+Genera +(progn + +(defun aref-card8 (a i) + (aref a i)) + +(defun aset-card8 (v a i) + (zl:aset v a i)) + +(defun aref-int8 (a i) + (card8->int8 (aref a i))) + +(defun aset-int8 (v a i) + (zl:aset (int8->card8 v) a i)) + +) + +#+lcl3.0 ;in lcl2.1 these symbols are in different packages and making too + ;many conditionalizations makes my brain hurt. +(progn + +(defun aref-card8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card8)) + #.(declare-buffun) + (the card8 (sys:svref-8bit a i))) + +(defun aset-card8 (v a i) + (declare (type card8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:svref-8bit a i) v)) + +(defun aref-int8 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int8)) + #.(declare-buffun) + (the int8 (sys:svref-signed-8bit a i))) + +(defun aset-int8 (v a i) + (declare (type int8 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:svref-signed-8bit a i) v)) + +) + +#+clx-overlapping-arrays +(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 + aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) + +#+(and clx-overlapping-arrays Genera) +(progn + +(defun aref-card16 (a i) + (aref a i)) + +(defun aset-card16 (v a i) + (zl:aset v a i)) + +(defun aref-int16 (a i) + (card16->int16 (aref a i))) + +(defun aset-int16 (v a i) + (zl:aset (int16->card16 v) a i) + v) + +(defun aref-card32 (a i) + (int32->card32 (aref a i))) + +(defun aset-card32 (v a i) + (zl:aset (card32->int32 v) a i)) + +(defun aref-int32 (a i) (aref a i)) + +(defun aset-int32 (v a i) + (zl:aset v a i)) + +(defun aref-card29 (a i) + (aref a i)) + +(defun aset-card29 (v a i) + (zl:aset v a i)) + +) + +#+(and clx-overlapping-arrays (not Genera)) +(progn + +(defun aref-card16 (a i) + (aref a i)) + +(defun aset-card16 (v a i) + (setf (aref a i) v)) + +(defun aref-int16 (a i) + (card16->int16 (aref a i))) + +(defun aset-int16 (v a i) + (setf (aref a i) (int16->card16 v)) + v) + +(defun aref-card32 (a i) + (aref a i)) + +(defun aset-card32 (v a i) + (setf (aref a i) v)) + +(defun aref-int32 (a i) + (card32->int32 (aref a i))) + +(defun aset-int32 (v a i) + (setf (aref a i) (int32->card32 v)) + v) + +(defun aref-card29 (a i) + (aref a i)) + +(defun aset-card29 (v a i) + (setf (aref a i) v)) + +) + +#+excl +(progn + + (defun aref-card16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card16)) + #.(declare-buffun) + (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-word))) + + (defun aset-card16 (v a i) + (declare (type card16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-word) v)) + + (defun aref-int16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int16)) + #.(declare-buffun) + (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-word))) + + (defun aset-int16 (v a i) + (declare (type int16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-word) v)) + + (defun aref-card32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card32)) + #.(declare-buffun) + (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long))) + + (defun aset-card32 (v a i) + (declare (type card32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long) v)) + + (defun aref-int32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int32)) + #.(declare-buffun) + (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-long))) + + (defun aset-int32 (v a i) + (declare (type int32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :signed-long) v)) + + (defun aref-card29 (a i) + ;; Do I need to mask off a few bits here? XXX + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card29)) + #.(declare-buffun) + (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long))) + + (defun aset-card29 (v a i) + (declare (type card29 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i + :unsigned-long) v)) + + +) + +#+lcl3.0 +(progn ;; all these lucid optimizations need to be compiled to work. + +(defun aref-card16 (a i) + #.(declare-buffun) + (the card16 (sys:svref-16bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -1)))) + +(defun aset-card16 (v a i) + #.(declare-buffun) + (setf (sys:svref-16bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -1)) + (the card16 v))) + +(defun aref-int16 (a i) + #.(declare-buffun) + (the int16 + (sys:svref-signed-16bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -1)))) + +(defun aset-int16 (v a i) + #.(declare-buffun) + (setf (sys:svref-signed-16bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -1)) + (the int16 v))) + +(defun aref-card32 (a i) + #.(declare-buffun) + (the card32 + (sys:svref-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)))) + +(defun aset-card32 (v a i) + #.(declare-buffun) + (setf (sys:svref-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)) + (the card32 v))) + +(defun aref-int32 (a i) + #.(declare-buffun) + (the int32 + (sys:svref-signed-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)))) + +(defun aset-int32 (v a i) + #.(declare-buffun) + (setf (sys:svref-signed-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)) + (the int32 v))) + +(defun aref-card29 (a i) + ;; Don't need to mask bits here since X protocol guarantees top bits zero + #.(declare-buffun) + (the card29 + (sys:svref-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)))) + +(defun aset-card29 (v a i) + ;; I also assume here Lisp is passing a number that fits in 29 bits. + #.(declare-buffun) + (setf (sys:svref-32bit (the buffer-bytes a) + (lucid:ash& (the array-index i) -2)) + (the card29 v))) +) + + + +#-(or excl lcl3.0 clx-overlapping-arrays) +(progn + +(defun aref-card16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card16)) + #.(declare-buffun) + (the card16 + (logior (the card16 + (ash (the card8 (aref a (index+ i *word-1*))) 8)) + (the card8 + (aref a (index+ i *word-0*)))))) + +(defun aset-card16 (v a i) + (declare (type card16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-int16 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int16)) + #.(declare-buffun) + (the int16 + (logior (the int16 + (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8)) + (the card8 + (aref a (index+ i *word-0*)))))) + +(defun aset-int16 (v a i) + (declare (type int16 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-card32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card32)) + #.(declare-buffun) + (the card32 + (logior (the card32 + (ash (the card8 (aref a (index+ i *long-3*))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i *long-2*))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i *long-1*))) 8)) + (the card8 + (aref a (index+ i *long-0*)))))) + +(defun aset-card32 (v a i) + (declare (type card32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v)) + (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-int32 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values int32)) + #.(declare-buffun) + (the int32 + (logior (the int32 + (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i *long-2*))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i *long-1*))) 8)) + (the card8 + (aref a (index+ i *long-0*)))))) + +(defun aset-int32 (v a i) + (declare (type int32 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v)) + (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v))) + v) + +(defun aref-card29 (a i) + (declare (type buffer-bytes a) + (type array-index i)) + (declare (values card29)) + #.(declare-buffun) + (the card29 + (logior (the card29 + (ash (the card8 (aref a (index+ i *long-3*))) 24)) + (the card29 + (ash (the card8 (aref a (index+ i *long-2*))) 16)) + (the card16 + (ash (the card8 (aref a (index+ i *long-1*))) 8)) + (the card8 + (aref a (index+ i *long-0*)))))) + +(defun aset-card29 (v a i) + (declare (type card29 v) + (type buffer-bytes a) + (type array-index i)) + #.(declare-buffun) + (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v)) + (aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v)) + (aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v)) + (aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v))) + v) + +) + +(defsetf aref-card8 (a i) (v) + `(aset-card8 ,v ,a ,i)) + +(defsetf aref-int8 (a i) (v) + `(aset-int8 ,v ,a ,i)) + +(defsetf aref-card16 (a i) (v) + `(aset-card16 ,v ,a ,i)) + +(defsetf aref-int16 (a i) (v) + `(aset-int16 ,v ,a ,i)) + +(defsetf aref-card32 (a i) (v) + `(aset-card32 ,v ,a ,i)) + +(defsetf aref-int32 (a i) (v) + `(aset-int32 ,v ,a ,i)) + +(defsetf aref-card29 (a i) (v) + `(aset-card29 ,v ,a ,i)) + +;;; Other random conversions + +(defun rgb-val->card16 (value) + ;; Short floats are good enough + (declare (type rgb-val value)) + (declare (values card16)) + #.(declare-buffun) + ;; Convert VALUE from float to card16 + (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) + +(defun card16->rgb-val (value) + ;; Short floats are good enough + (declare (type card16 value)) + (declare (values short-float)) + #.(declare-buffun) + ;; Convert VALUE from card16 to float + (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) + +(defun radians->int16 (value) + ;; Short floats are good enough + (declare (type angle value)) + (declare (values int16)) + #.(declare-buffun) + (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) + +(defun int16->radians (value) + ;; Short floats are good enough + (declare (type int16 value)) + (declare (values short-float)) + #.(declare-buffun) + (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) + + +;;----------------------------------------------------------------------------- +;; Character transformation +;;----------------------------------------------------------------------------- + + +;;; This stuff transforms chars to ascii codes in card8's and back. +;;; You might have to hack it a little to get it to work for your machine. + +(declaim (inline char->card8 card8->char)) + +(macrolet ((char-translators () + (let ((alist + `(#-lispm + ;; The normal ascii codes for the control characters. + ,@`((#\Return . 13) + (#\Linefeed . 10) + (#\Rubout . 127) + (#\Page . 12) + (#\Tab . 9) + (#\Backspace . 8) + (#\Newline . 10) + (#\Space . 32)) + ;; One the lispm, #\Newline is #\Return, but we'd really like + ;; #\Newline to translate to ascii code 10, so we swap the + ;; Ascii codes for #\Return and #\Linefeed. We also provide + ;; mappings from the counterparts of these control characters + ;; so that the character mapping from the lisp machine + ;; character set to ascii is invertible. + #+lispm + ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) + (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) + (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) + (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) + (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) + (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) + (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) + (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) + ;; The rest of the common lisp charater set with the normal + ;; ascii codes for them. + (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) + (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) + (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) + (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) + (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) + (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) + (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) + (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) + (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) + (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) + (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) + (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) + (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) + (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) + (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) + (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) + (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) + (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) + (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) + (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) + (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) + (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) + (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) + (#\} . 125) (#\~ . 126)))) + (cond ((dolist (pair alist nil) + (when (not (= (char-code (car pair)) (cdr pair))) + (return t))) + `(progn + (defconstant *char-to-card8-translation-table* + ',(let ((array (make-array + (let ((max-char-code 255)) + (dolist (pair alist) + (setq max-char-code + (max max-char-code + (char-code (car pair))))) + (1+ max-char-code)) + :element-type 'card8))) + (dotimes (i (length array)) + (setf (aref array i) (mod i 256))) + (dolist (pair alist) + (setf (aref array (char-code (car pair))) + (cdr pair))) + array)) + (defconstant *card8-to-char-translation-table* + ',(let ((array (make-string 256))) + (dotimes (i (length array)) + (setf (aref array i) (code-char i))) + (dolist (pair alist) + (setf (aref array (cdr pair)) (car pair))) + array)) + #-Genera + (progn + (defun char->card8 (char) + (declare (type string-char char)) + #.(declare-buffun) + (the card8 (aref (the (simple-array card8 (*)) + *char-to-card8-translation-table*) + (the array-index (char-code char))))) + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the string-char + (aref (the simple-string *card8-to-char-translation-table*) + card8))) + ) + #+Genera + (progn + (defun char->card8 (char) + (declare lt:(side-effects reader reducible)) + (aref *char-to-card8-translation-table* (char-code char))) + (defun card8->char (card8) + (declare lt:(side-effects reader reducible)) + (aref *card8-to-char-translation-table* card8)) + ) + (dotimes (i 256) + (unless (= i (char->card8 (card8->char i))) + (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" + (list i + (card8->char i) + (char->card8 (card8->char i)))) + (return nil))) + (dotimes (i (length *char-to-card8-translation-table*)) + (let ((char (code-char i))) + (unless (eql char (card8->char (char->card8 char))) + (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" + (list char + (char->card8 char) + (card8->char (char->card8 char)))) + (return nil)))))) + (t + `(progn + (defun char->card8 (char) + (declare (type string-char char)) + #.(declare-buffun) + (the card8 (char-code char))) + (defun card8->char (card8) + (declare (type card8 card8)) + #.(declare-buffun) + (the string-char (code-char card8))) + )))))) + (char-translators)) + +;;----------------------------------------------------------------------------- +;; Process Locking +;; +;; Common-Lisp doesn't provide process locking primitives, so we define +;; our own here, based on Zetalisp primitives. Holding-Lock is very +;; similar to with-lock on The TI Explorer, and a little more efficient +;; than with-process-lock on a Symbolics. +;;----------------------------------------------------------------------------- + +;;; MAKE-PROCESS-LOCK: Creating a process lock. + +#-(or LispM excl) +(defun make-process-lock (name) + (declare (ignore name)) + nil) + +#+excl +(defun make-process-lock (name) + (mp:make-process-lock :name name)) + +#+(and LispM (not Genera)) +(defun make-process-lock (name) + (vector nil name)) + +#+Genera +(defun make-process-lock (name) + (process:make-lock name :flavor 'clx-lock)) + +;;; HOLDING-LOCK: Execute a body of code with a lock held. + +;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN +;;; passes its timeout to the holding-lock macro, so any timeout you want to +;;; work for event-listen you should do for holding-lock. + +;; If you're not sharing DISPLAY objects within a multi-processing +;; shared-memory environment, this is sufficient +#-(or lispm excl lcl3.0) +(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) + (declare (ignore locator display whostate timeout)) + `(progn ,@body)) + +#+Genera +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore whostate)) + `(process:with-lock (,locator :timeout ,timeout) + (let ((.debug-io. (buffer-debug-io ,display))) + (scl:let-if .debug-io. ((*debug-io* .debug-io.)) + ,@body)))) + +#+(and lispm (not Genera)) +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display)) + ;; This macro is for use in a multi-process environment. + (let ((lock (gensym)) + (have-lock (gensym)) + (timeo (gensym))) + `(let* ((,lock (zl:locf (svref ,locator 0))) + (,have-lock (eq (car ,lock) sys:current-process)) + (,timeo ,timeout)) + (unwind-protect + (when (cond (,have-lock) + ((#+explorer si:%store-conditional + #-explorer sys:store-conditional + ,lock nil sys:current-process)) + ((null ,timeo) + (sys:process-lock ,lock nil ,(or whostate "CLX Lock"))) + ((sys:process-wait-with-timeout + ,(or whostate "CLX Lock") (round (* ,timeo 60.)) + #'(lambda (lock process) + (#+explorer si:%store-conditional + #-explorer sys:store-conditional + lock nil process)) + ,lock sys:current-process))) + ,@body) + (unless ,have-lock + (#+explorer si:%store-conditional + #-explorer sys:store-conditional + ,lock sys:current-process nil)))))) + +;; Lucid has a process locking mechanism as well under release 3.0 +#+lcl3.0 +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display)) + (if timeout + ;; Hair to support timeout. + `(let ((.have-lock. (eq ,locator lcl:*current-process*)) + (.timeout. ,timeout)) + (unwind-protect + (when (cond (.have-lock.) + ((conditional-store ,locator nil lcl:*current-process*)) + ((null .timeout.) + (lcl:process-lock ,locator) + t) + ((lcl:process-wait-with-timeout ,whostate .timeout. + #'(lambda () + (conditional-store ,locator nil lcl:*current-process*))))) + ,@body) + (unless .have-lock. + (lcl:process-unlock ,locator)))) + `(lcl:with-process-lock (,locator) + ,@body))) + + +#+excl +(defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display)) + `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) + (unwind-protect + (block .hl-doit. + (when mp::*scheduler-stack-group* ; fast test for scheduler running + (setq .hl-lock. ,locator + .hl-curproc. mp::*current-process*) + (when (and .hl-curproc. ; nil if in process-wait fun + (not (eq (mp::process-lock-locker .hl-lock.) + .hl-curproc.))) + ;; Then we need to grab the lock. + ,(if timeout + `(if (not (mp::process-lock .hl-lock. .hl-curproc. + ,whostate ,timeout)) + (return-from .hl-doit. nil)) + `(mp::process-lock .hl-lock. .hl-curproc. + ,@(when whostate `(,whostate)))) + (setq .hl-obtained-lock. t))) + ,@body) + (if (and .hl-obtained-lock. + ;; Note -- next form added to allow error handler inside + ;; body to unlock the lock prematurely if it knows that + ;; the current process cannot possibly continue but will + ;; throw out (or is it throw up?). + (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) + (mp::process-unlock .hl-lock. .hl-curproc.))))) + + +;;; WITHOUT-ABORTS + +;;; If you can inhibit asynchronous keyboard aborts inside the body of this +;;; macro, then it is a good idea to do this. This macro is wrapped around +;;; request writing and reply reading to ensure that requests are atomically +;;; written and replies are atomically read from the stream. + +#-(or Genera excl lcl3.0) +(defmacro without-aborts (&body body) + `(progn ,@body)) + +#+Genera +(defmacro without-aborts (&body body) + `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.") + ,@body)) + +#+excl +(defmacro without-aborts (&body body) + `(without-interrupts ,@body)) + +#+lcl3.0 +(defmacro without-aborts (&body body) + `(lcl:with-interruptions-inhibited ,@body)) + +;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. +;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's +;;; value changes. + +#-(or lispm excl lcl3.0) +(defun process-block (whostate predicate &rest predicate-args) + (declare (ignore whostate)) + (or (apply predicate predicate-args) + (error "Program tried to wait with no scheduler."))) + +#+Genera +(defun process-block (whostate predicate &rest predicate-args) + (declare (type function predicate) + (downward-funarg predicate)) + (apply #'process:block-process whostate predicate predicate-args)) + +#+(and lispm (not Genera)) +(defun process-block (whostate predicate &rest predicate-args) + (declare (type function predicate) + (downward-funarg predicate)) + (apply #'global:process-wait whostate predicate predicate-args)) + +#+excl +(defun process-block (whostate predicate &rest predicate-args) + (if mp::*scheduler-stack-group* + (apply #'mp::process-wait whostate predicate predicate-args) + (or (apply predicate predicate-args) + (error "Program tried to wait with no scheduler.")))) + +#+lcl3.0 +(defun process-block (whostate predicate &rest predicate-args) + (declare (dynamic-extent predicate-args)) + (apply #'lcl:process-wait whostate predicate predicate-args)) + +;;; PROCESS-WAKEUP: Check some other process' wait function. + +(declaim (inline process-wakeup)) + +#-(or excl Genera) +(defun process-wakeup (process) + (declare (ignore process)) + nil) + +#+excl +(defun process-wakeup (process) + (let ((curproc mp::*current-process*)) + (when (and curproc process) + (unless (mp::process-p curproc) + (error "~s is not a process" curproc)) + (unless (mp::process-p process) + (error "~s is not a process" process)) + (if (> (mp::process-priority process) (mp::process-priority curproc)) + (mp::process-allow-schedule process))))) + +#+Genera +(defun process-wakeup (process) + (process:wakeup process)) + +;;; CURRENT-PROCESS: Return the current process object for input locking and +;;; for calling PROCESS-WAKEUP. + +(declaim (inline current-process)) + +;;; Default return NIL, which is acceptable even if there is a scheduler. + +#-(or lispm excl lcl3.0) +(defun current-process () + nil) + +#+lispm +(defun current-process () + sys:current-process) + +#+excl +(defun current-process () + (and mp::*scheduler-stack-group* + mp::*current-process*)) + +#+lcl3.0 +(defun current-process () + lcl:*current-process*) + +;;; WITHOUT-INTERRUPTS -- provide for atomic operations. + +#-(or lispm excl lcl3.0) +(defmacro without-interrupts (&body body) + `(progn ,@body)) + +#+(and lispm (not Genera)) +(defmacro without-interrupts (&body body) + `(sys:without-interrupts ,@body)) + +#+Genera +(defmacro without-interrupts (&body body) + `(process:with-no-other-processes ,@body)) + +#+LCL3.0 +(defmacro without-interrupts (&body body) + `(lcl:with-scheduling-inhibited ,@body)) + +;;; CONDITIONAL-STORE: + +;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. +;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. +(defmacro conditional-store (place old-value new-value) + `(without-interrupts + (cond ((eq ,place ,old-value) + (setf ,place ,new-value) + t)))) + +;;;---------------------------------------------------------------------------- +;;; IO Error Recovery +;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. +;;; It prevents multiple mindless errors when the network craters. +;;; +;;;---------------------------------------------------------------------------- + +#-Genera +(defmacro wrap-buf-output ((buffer) &body body) + ;; Error recovery wrapper + `(unless (buffer-dead ,buffer) + ,@body)) + +#+Genera +(defmacro wrap-buf-output ((buffer) &body body) + ;; Error recovery wrapper + `(let ((.buffer. ,buffer)) + (unless (buffer-dead .buffer.) + (scl:condition-bind + (((sys:network-error) + #'(lambda (error) + (scl:condition-case () + (funcall (buffer-close-function .buffer.) .buffer. :abort t) + (sys:network-error)) + (setf (buffer-dead .buffer.) error) + (setf (buffer-output-stream .buffer.) nil) + (setf (buffer-input-stream .buffer.) nil) + nil))) + ,@body)))) + +#-Genera +(defmacro wrap-buf-input ((buffer) &body body) + (declare (ignore buffer)) + ;; Error recovery wrapper + `(progn ,@body)) + +#+Genera +(defmacro wrap-buf-input ((buffer) &body body) + ;; Error recovery wrapper + `(let ((.buffer. ,buffer)) + (scl:condition-bind + (((sys:network-error) + #'(lambda (error) + (scl:condition-case () + (funcall (buffer-close-function .buffer.) .buffer. :abort t) + (sys:network-error)) + (setf (buffer-dead .buffer.) error) + (setf (buffer-output-stream .buffer.) nil) + (setf (buffer-input-stream .buffer.) nil) + nil))) + ,@body))) + + +;;;---------------------------------------------------------------------------- +;;; System dependent IO primitives +;;; Functions for opening, reading writing forcing-output and closing +;;; the stream to the server. +;;;---------------------------------------------------------------------------- + +;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X +;;; server + +#-(or explorer Genera lucid kcl ibcl excl) +(defun open-x-stream (host display protocol) + host display protocol ;; unused + (error "OPEN-X-STREAM not implemented yet.")) + +;;; Genera: + +;;; TCP and DNA are both layered products, so try to work with either one. + +#+Genera +(when (fboundp 'tcp:add-tcp-port-for-protocol) + (tcp:add-tcp-port-for-protocol :x-window-system 6000)) + +#+Genera +(when (fboundp 'dna:add-dna-contact-id-for-protocol) + (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0")) + +#+Genera +(net:define-protocol :x-window-system (:x-window-system :byte-stream) + (:invoke-with-stream ((stream :characters nil :ascii-translation nil)) + stream)) + +#+Genera +(eval-when (compile) + (compiler:function-defined 'tcp:open-tcp-stream) + (compiler:function-defined 'dna:open-dna-bidirectional-stream)) + +#+Genera +(defun open-x-stream (host display protocol) + (let ((host (net:parse-host host))) + (if (or protocol (plusp display)) + ;; The protocol was specified or the display isn't 0, so we + ;; can't use the Generic Network System. If the protocol was + ;; specified, then use that protocol, otherwise, blindly use + ;; TCP. + (ccase protocol + ((:tcp nil) + (tcp:open-tcp-stream + host (+ *x-tcp-port* display) nil + :direction :io + :characters nil + :ascii-translation nil)) + ((:dna) + (dna:open-dna-bidirectional-stream + host (format nil "X$X~D" display) + :characters nil + :ascii-translation nil))) + (let ((neti:*invoke-service-automatic-retry* t)) + (net:invoke-service-on-host :x-window-system host))))) + +#+explorer +(defun open-x-stream (host display protocol) + (declare (ignore protocol)) + (net:open-connection-on-medium + (net:parse-host host) ;Host + :byte-stream ;Medium + "X11" ;Logical contact name + :stream-type :character-stream + :direction :bidirectional + :timeout-after-open nil + :remote-port (+ *x-tcp-port* display))) + +#+explorer +(net:define-logical-contact-name + "X11" + `((:local "X11") + (:chaos "X11") + (:nsp-stream "X11") + (:tcp ,*x-tcp-port*))) + +#+lucid +(defun open-x-stream (host display protocol) + protocol ;; unused + (let ((fd (connect-to-server host display))) + (when (minusp fd) + (error "Failed to connect to server: ~A ~D" host display)) + (user::make-lisp-stream :input-handle fd + :output-handle fd + :element-type 'unsigned-byte + #-lcl3.0 :stream-type #-lcl3.0 :ephemeral))) + +#+(or kcl ibcl) +(defun open-x-stream (host display protocol) + protocol ;; unused + (let ((stream (open-socket-stream host display))) + (if (streamp stream) + stream + (error "Cannot connect to server: ~A:~D" host display)))) + +#+excl +;; +;; Note that since we don't use the CL i/o facilities to do i/o, the display +;; input and output "stream" is really a file descriptor (fixnum). +;; +(defun open-x-stream (host display protocol) + (declare (ignore protocol));; unused + (let ((fd (connect-to-server (string host) display))) + (when (minusp fd) + (error "Failed to connect to server: ~A ~D" host display)) + fd)) + +;;; BUFFER-READ-DEFAULT - read data from the X stream + +#+(or Genera explorer) +(defun buffer-read-default (display vector start end timeout) + ;; returns non-NIL if EOF encountered + ;; Returns :TIMEOUT when timeout exceeded + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null number) timeout)) + #.(declare-buffun) + (let ((stream (display-input-stream display))) + (or (cond ((null stream)) + ((funcall stream :listen) nil) + ((eql timeout 0) :timeout) + ((buffer-input-wait-default display timeout))) + (multiple-value-bind (ignore eofp) + (funcall stream :string-in nil vector start end) + eofp)))) + + +#+excl +;; +;; Rewritten 10/89 to not use foreign function interface to do I/O. +;; +(defun buffer-read-default (display vector start end timeout) + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null number) timeout)) + #.(declare-buffun) + + (let* ((howmany (- end start)) + (fd (display-input-stream display))) + (declare (type array-index howmany) + (fixnum fd)) + + (or (cond ((fd-char-avail-p fd) nil) + ((eql timeout 0) :timeout) + ((buffer-input-wait-default display timeout))) + (fd-read-bytes fd vector start howmany)))) + + +#+lcl3.0 +(defmacro extract-underlying-stream (stream display direction) + ;;;Our job is to quickly get at the underlying stream for this display's + ;;;input stream structure. + `(or (getf (display-plist ,display) ,direction) + (setf (getf (display-plist ,display) ,direction) + (lucid::underlying-stream + ,stream (if (eq ,direction 'input) :input :output))))) + +#+lcl3.0 +(defun buffer-read-default (display vector start end timeout) + ;;Note that LISTEN must still be done on "slow stream" or the I/O system + ;;gets confused. But reading should be done from "fast stream" for speed. + ;;We used to inhibit scheduling because there were races in Lucid's + ;;multitasking system. Empirical evidence suggests they may be gone now. + ;;Should you decide you need to inhibit scheduling, do it around the do*. + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null number) timeout) + (optimize (speed 3) + (safety 0))) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (or (cond ((null stream)) + ((listen stream) nil) + ((eql timeout 0) :timeout) + ((buffer-input-wait-default display timeout))) + (let ((stream (extract-underlying-stream stream display 'input))) + (do* ((index start (index1+ index))) + ((index>= index end) nil) + (declare (type array-index index)) + (let ((c (lcl:fast-read-byte stream (unsigned-byte 8) nil nil))) + (declare (type (or null card8) c)) + (if (null c) + (return t) + (setf (aref vector index) (the card8 c))))))))) + + + +;;; WARNING: +;;; CLX performance will suffer if your lisp uses read-byte for +;;; receiving all data from the X Window System server. +;;; You are encouraged to write a specialized version of +;;; buffer-read-default that does block transfers. +#-(or Genera explorer excl lcl3.0) +(defun buffer-read-default (display vector start end timeout) + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (type (or null (rational 0 *) (float 0.0 *)) timeout)) + #.(declare-buffun) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (or (cond ((null stream)) + ((listen stream) nil) + ((eql timeout 0) :timeout) + ((buffer-input-wait-default display timeout))) + (do* ((index start (index1+ index))) + ((index>= index end) nil) + (declare (type array-index index)) + (let ((c (read-byte stream nil nil))) + (declare (type (or null card8) c)) + (if (null c) + (return t) + (setf (aref vector index) (the card8 c)))))))) + +;;; BUFFER-WRITE-DEFAULT - write data to the X stream + +#+(or Genera explorer) +(defun buffer-write-default (vector display start end) + ;; The default buffer write function for use with common-lisp streams + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (write-string vector stream :start start :end end)))) + +#+excl +(defun buffer-write-default (vector display start end) + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (excl::filesys-write-bytes (display-output-stream display) vector start + (- end start))) + +#+lcl3.0 +(defun buffer-write-default (vector display start end) + ;;We inhibit scheduling here because there seem to be races in Lucid's + ;;multitasking implementation. Anyway, when we take it out we get bugs! + (declare (type display display) + (type buffer-bytes vector) + (type array-index start end) + (optimize (:tail-merge nil) + (speed 3) + (safety 0))) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (let ((stream (extract-underlying-stream stream display 'output))) + (lcl:with-scheduling-inhibited + (lcl:write-array stream vector start end)))))) + +;;; WARNING: +;;; CLX performance will be severely degraded if your lisp uses +;;; write-byte to send all data to the X Window System server. +;;; You are STRONGLY encouraged to write a specialized version +;;; of buffer-write-default that does block transfers. + +#-(or Genera explorer excl lcl3.0) +(defun buffer-write-default (vector display start end) + ;; The default buffer write function for use with common-lisp streams + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (with-vector (vector buffer-bytes) + (do ((index start (index1+ index))) + ((index>= index end)) + (declare (type array-index index)) + (write-byte (aref vector index) stream)))))) + +;;; buffer-force-output-default - force output to the X stream + +#+excl +(defun buffer-force-output-default (display) + ;; buffer-write-default does the actual writing. + (declare (ignore display))) + +#-excl +(defun buffer-force-output-default (display) + ;; The default buffer force-output function for use with common-lisp streams + (declare (type display display)) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (force-output stream)))) + +;;; BUFFER-CLOSE-DEFAULT - close the X stream + +#+excl +(defun buffer-close-default (display &key abort) + ;; The default buffer close function for use with common-lisp streams + (declare (type display display) + (ignore abort)) + #.(declare-buffun) + (excl::filesys-checking-close (display-output-stream display))) + +#-excl +(defun buffer-close-default (display &key abort) + ;; The default buffer close function for use with common-lisp streams + (declare (type display display)) + #.(declare-buffun) + (let ((stream (display-output-stream display))) + (declare (type (or null stream) stream)) + (unless (null stream) + (close stream :abort abort)))) + +;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the +;;; buffer. This is called in read-input between requests, so that a process +;;; waiting for input is abortable when between requests. Should return +;;; :TIMEOUT if it times out, NIL otherwise. + +;;; The default implementation + +;; Poll for input every *buffer-read-polling-time* SECONDS. +#-(or Genera explorer excl lcl3.0) +(defparameter *buffer-read-polling-time* 0.5) + +#-(or Genera explorer excl lcl3.0) +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout)) + (declare (values timeout)) + + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((listen stream) nil) + ((eql timeout 0) :timeout) + ((not (null timeout)) + (multiple-value-bind (npoll fraction) + (truncate timeout *buffer-read-polling-time*) + (dotimes (i npoll) ; Sleep for a time, then listen again + (sleep *buffer-read-polling-time*) + (when (listen stream) + (return-from buffer-input-wait-default nil))) + (when (plusp fraction) + (sleep fraction) ; Sleep a fraction of a second + (when (listen stream) ; and listen one last time + (return-from buffer-input-wait-default nil))) + :timeout))))) + +#+Genera +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout)) + (declare (values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((scl:send stream :listen) nil) + ((eql timeout 0) :timeout) + ((null timeout) (si:stream-input-block stream "CLX Input")) + (t + (scl:condition-bind ((neti:protocol-timeout + #'(lambda (error) + (when (eq stream (scl:send error :stream)) + (return-from buffer-input-wait-default :timeout))))) + (neti:with-stream-timeout (stream :input timeout) + (si:stream-input-block stream "CLX Input"))))) + nil)) + +#+explorer +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout)) + (declare (values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((zl:send stream :listen) nil) + ((eql timeout 0) :timeout) + ((null timeout) + (si:process-wait "CLX Input" stream :listen)) + (t + (unless (si:process-wait-with-timeout + "CLX Input" (round (* timeout 60.)) stream :listen) + (return-from buffer-input-wait-default :timeout)))) + nil)) + +#+excl +;; +;; This is used so an 'eq' test may be used to find out whether or not we can +;; safely throw this process out of the CLX read loop. +;; +(defparameter *read-whostate* "blocked on read from X server") + +;; +;; Note that this function returns nil on error if the scheduler is running, +;; t on error if not. This is ok since buffer-read will detect the error. +;; +#+excl +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout)) + (declare (values timeout)) + (let ((fd (display-input-stream display))) + (declare (fixnum fd)) + (when (>= fd 0) + (cond ((fd-char-avail-p fd) + nil) + + ;; Otherwise no bytes were available on the socket + ((and timeout (zerop timeout)) + ;; If there aren't enough and timeout == 0, timeout. + :timeout) + + ;; If the scheduler is running let it do timeouts. + (mp::*scheduler-stack-group* + #+allegro + (if (not + (mp:wait-for-input-available fd :whostate *read-whostate* + :wait-function #'fd-char-avail-p + :timeout timeout)) + (return-from buffer-input-wait-default :timeout)) + #-allegro + (mp::wait-for-input-available fd :whostate *read-whostate* + :wait-function #'fd-char-avail-p)) + + ;; Otherwise we have to handle timeouts by hand, and call select() + ;; to block until input is available. Note we don't really handle + ;; the interaction of interrupts and (numberp timeout) here. XX + (t + (let ((res 0)) + (declare (fixnum res)) + (with-interrupt-checking-on + (loop + (setq res (fd-wait-for-input fd (if (null timeout) 0 + (truncate timeout)))) + (cond ((plusp res) ; success + (return nil)) + ((eq res 0) ; timeout + (return :timeout)) + ((eq res -1) ; error + (return t)) + ;; Otherwise we got an interrupt -- go around again. + ))))))))) + + +#+lcl3.0 +(defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null number) timeout) + (optimize (speed 3) (safety 0))) + (declare (values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((listen stream) nil) + ((eql timeout 0) :timeout) + ((let ((stream (extract-underlying-stream stream display 'input))) + (lucid::waiting-for-input-from-stream stream + (lucid::with-io-unlocked + (if (null timeout) + (lcl:process-wait "CLX Input" #'listen stream) + (lcl:process-wait-with-timeout + "CLX Input" timeout #'listen stream))))) + nil) + (:timeout)))) + + +;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the +;;; buffer. This should never block, so it can be called from the scheduler. + +;;; The default implementation is to just use listen. +#-excl +(defun buffer-listen-default (display) + (declare (type display display)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (if (null stream) + t + (listen stream)))) + +#+excl +(defun buffer-listen-default (display) + (declare (type display display)) + (let ((fd (display-input-stream display))) + (declare (type fixnum fd)) + (if (= fd -1) + t + (fd-char-avail-p fd)))) + + +;;;---------------------------------------------------------------------------- +;;; System dependent speed hacks +;;;---------------------------------------------------------------------------- + +;; +;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. +;; If your lisp doesn't have stack-lists, and you're worried about +;; consing garbage, you may want to re-write this to allocate and +;; initialize lists from a resource. +;; +#+lispm +(defmacro with-stack-list ((var &rest elements) &body body) + `(sys:with-stack-list (,var ,@elements) ,@body)) + +#+lispm +(defmacro with-stack-list* ((var &rest elements) &body body) + `(sys:with-stack-list* (,var ,@elements) ,@body)) + +#-lispm +(defmacro with-stack-list ((var &rest elements) &body body) + ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) + ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) + ;; except that the list produced by MAPCAR resides on the stack and + ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. + `(let ((,var (list ,@elements))) ,@body)) + +#-lispm +(defmacro with-stack-list* ((var &rest elements) &body body) + ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) + ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) + ;; except that the list produced by MAPCAR resides on the stack and + ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. + `(let ((,var (list* ,@elements))) ,@body)) + +(declaim (inline buffer-replace)) + +#+lispm +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type vector buf1 buf2) + (type array-index start1 end1 start2)) + (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1)) + +#+excl +(defun buffer-replace (target-sequence source-sequence target-start + target-end &optional (source-start 0)) + (declare (type buffer-bytes target-sequence source-sequence) + (type array-index target-start target-end source-start) + (optimize (speed 3) (safety 0))) + + (let ((source-end (length source-sequence))) + (declare (type array-index source-end)) + + (if* (and (eq target-sequence source-sequence) + (> target-start source-start)) + then (let ((nelts (min (- target-end target-start) + (- source-end source-start)))) + (do ((target-index (+ target-start nelts -1) (1- target-index)) + (source-index (+ source-start nelts -1) (1- source-index))) + ((= target-index (1- target-start)) target-sequence) + (declare (type array-index target-index source-index)) + + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))) + else (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index))) + ((or (= target-index target-end) (= source-index source-end)) + target-sequence) + (declare (type array-index target-index source-index)) + + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))))) + +#+lucid +;;;The compiler is *supposed* to optimize calls to replace, but in actual +;;;fact it does not. +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type buffer-bytes buf1 buf2) + (type array-index start1 end1 start2)) + #.(declare-buffun) + (let ((end2 (lucid::%simple-8bit-vector-length buf2))) + (declare (type array-index end2)) + (lucid::simple-8bit-vector-replace-internal + buf1 buf2 start1 end1 start2 end2))) + +#+(and clx-overlapping-arrays (not (or lispm excl))) +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type vector buf1 buf2) + (type array-index start1 end1 start2)) + (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) + +#-(or lispm lucid excl clx-overlapping-arrays) +(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) + (declare (type buffer-bytes buf1 buf2) + (type array-index start1 end1 start2)) + (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) + +#+ti +(defun with-location-bindings (sys:"e bindings &rest body) + (do ((bindings bindings (cdr bindings))) + ((null bindings) + (sys:eval-body-as-progn body)) + (sys:bind (sys:*eval `(sys:locf ,(caar bindings))) + (sys:*eval (cadar bindings))))) + +#+ti +(compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form) + (let ((bindings (cadr form)) + (body (cddr form))) + `(let () + ,@(loop for (accessor value) in bindings + collect `(si:bind (si:locf ,accessor) ,value)) + ,@body))) + +#+ti +(defun (:property with-location-bindings compiler::cw-handler) (exp) + (let* ((bindlist (mapcar #'compiler::cw-clause (second exp))) + (body (compiler::cw-clause (cddr exp)))) + (and compiler::cw-return-expansion-flag + (list* (first exp) bindlist body)))) + +#+(and lispm (not ti)) +(defmacro with-location-bindings (bindings &body body) + `(sys:letf* ,bindings ,@body)) + +#+lispm +(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) + &body body) + ;; don't use svref on LHS because Symbolics didn't define locf for it + (let* ((local-state (gensym)) + (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway + (dolist (index indexes) + (push `((aref ,local-state ,index) (svref ,saved-state ,index)) + bindings)) + `(let ((,local-state (gcontext-local-state ,gc))) + (declare (type gcontext-state ,local-state)) + (unwind-protect + (with-location-bindings ,bindings + ,@body) + (setf (svref ,local-state ,ts-index) 0) + (when ,temp-gc + (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) + (deallocate-gcontext-state ,saved-state))))) + +#-lispm +(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) + &body body) + (let ((local-state (gensym)) + (resets nil)) + (dolist (index indexes) + (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) + resets)) + `(unwind-protect + (progn + ,@body) + (let ((,local-state (gcontext-local-state ,gc))) + (declare (type gcontext-state ,local-state)) + ,@resets + (setf (svref ,local-state ,ts-index) 0)) + (when ,temp-gc + (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) + (deallocate-gcontext-state ,saved-state)))) + +;;;---------------------------------------------------------------------------- +;;; How error detection should CLX do? +;;; Several levels are possible: +;;; +;;; 1. Do the equivalent of check-type on every argument. +;;; +;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format +;;; strings generated by check-type. +;;; +;;; 3. Do error checking only on arguments that are likely to have errors +;;; (like keyword names) +;;; +;;; 4. Do error checking only where not doing so may dammage the envirnment +;;; on a non-tagged machine (i.e. when storing into a structure that has +;;; been passed in) +;;; +;;; 5. No extra error detection code. On lispm's, ASET may barf trying to +;;; store a non-integer into a number array. +;;; +;;; How extensive should the error checking be? For example, if the server +;;; expects a CARD16, is is sufficient for CLX to check for integer, or +;;; should it also check for non-negative and less than 65536? +;;;---------------------------------------------------------------------------- + +;; The *TYPE-CHECK?* constant controls how much error checking is done. +;; Possible values are: +;; NIL - Don't do any error checking +;; t - Do the equivalent of checktype on every argument +;; :minimal - Do error checking only where errors are likely + +;;; This controls macro expansion, and isn't changable at run-time You will +;;; probably want to set this to nil if you want good performance at +;;; production time. +(defconstant *type-check?* #+Genera nil #-Genera t) + +;; TYPE? is used to allow the code to do error checking at a different level from +;; the declarations. It also does some optimizations for systems that don't have +;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. +;; include range checks. You can modify TYPE? to do less extensive checking +;; for these types if you desire. + +(defmacro type? (object type) + (if (not (constantp type)) + `(typep ,object ,type) + (progn + (setq type (eval type)) + #+(or Genera explorer) + (if *type-check?* + `(locally (declare (optimize safety)) (typep ,object ',type)) + `(typep ,object ',type)) + #-(or Genera explorer) + (let ((predicate (assoc type + '((drawable drawable-p) (window window-p) + (pixmap pixmap-p) (cursor cursor-p) + (font font-p) (gcontext gcontext-p) + (colormap colormap-p) (null null) + (integer integerp))))) + (cond (predicate + `(,(second predicate) ,object)) + ((eq type 'boolean) + 't) ; Everything is a boolean. + (*type-check?* + `(locally (declare (optimize safety)) (typep ,object ',type))) + (t + `(typep ,object ',type))))))) + +;; X-TYPE-ERROR is the function called for type errors. +;; If you want lots of checking, but are concerned about code size, +;; this can be made into a macro that ignores some parameters. + +(defun x-type-error (object type &optional error-string) + (x-error 'x-type-error + :datum object + :expected-type type + :error-string error-string)) + + +;;----------------------------------------------------------------------------- +;; Error handlers +;; Hack up KMP error signaling using zetalisp until the real thing comes +;; along +;;----------------------------------------------------------------------------- + +(defun default-error-handler (display error-key &rest key-vals + &key asynchronous &allow-other-keys) + (declare (type boolean asynchronous) + (dynamic-extent key-vals)) + ;; The default display-error-handler. + ;; It signals the conditions listed in the DISPLAY file. + (if asynchronous + (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) + (apply #'x-error error-key :display display :error-key error-key key-vals))) + +#+(and lispm (not Genera) (not ansi-common-lisp)) +(defun x-error (condition &rest keyargs) + (apply #'sys:signal condition keyargs)) + +#+(and lispm (not Genera) (not ansi-common-lisp)) +(defun x-cerror (proceed-format-string condition &rest keyargs) + (sys:signal (apply #'zl:make-condition condition keyargs) + :proceed-types proceed-format-string)) + +#+(and Genera (not ansi-common-lisp)) +(defun x-error (condition &rest keyargs) + (declare (dbg:error-reporter)) + (apply #'sys:signal condition keyargs)) + +#+(and Genera (not ansi-common-lisp)) +(defun x-cerror (proceed-format-string condition &rest keyargs) + (declare (dbg:error-reporter)) + (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs)) + +#+(or ansi-common-lisp excl lcl3.0) +(defun x-error (condition &rest keyargs) + (declare (dynamic-extent keyargs)) + (apply #'error condition keyargs)) + +#+(or ansi-common-lisp excl lcl3.0) +(defun x-cerror (proceed-format-string condition &rest keyargs) + (declare (dynamic-extent keyargs)) + (apply #'cerror proceed-format-string condition keyargs)) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defun x-error (condition &rest keyargs) + (error "X-Error: ~a" + (princ-to-string (apply #'make-condition condition keyargs)))) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defun x-cerror (proceed-format-string condition &rest keyargs) + (cerror proceed-format-string "X-Error: ~a" + (princ-to-string (apply #'make-condition condition keyargs)))) + +;; version 15 of Pitman error handling defines the syntax for define-condition to be: +;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] +;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) +;; or (:report exp) + +#+(and lispm (not ansi-common-lisp)) +(defmacro define-condition (name parents &body options) + (let ((slots (pop options)) + (documentation nil) + (conc-name (concatenate 'string (string name) "-")) + (reporter nil)) + (dolist (item options) + (ecase (first item) + (:documentation (setq documentation (second item))) + (:conc-name (setq conc-name (string (second item)))) + (:report (setq reporter (second item))))) + `(within-definition (,name define-condition) + (zl:defflavor ,name ,slots ,parents + :initable-instance-variables + #-Genera + (:accessor-prefix ,conc-name) + #+Genera + (:conc-name ,conc-name) + #-Genera + (:outside-accessible-instance-variables ,@slots) + #+Genera + (:readable-instance-variables ,@slots)) + ,(when reporter ;; when no reporter, parent's is inherited + `(zl:defmethod #-Genera (,name :report) + #+Genera (dbg:report ,name) (stream) + ,(if (stringp reporter) + `(write-string ,reporter stream) + `(,reporter global:self stream)) + global:self)) + (zl:compile-flavor-methods ,name) + ,(when documentation + `(setf (documentation name 'type) ,documentation)) + ',name))) + +#+(and lispm (not Genera) (not ansi-common-lisp)) +(zl:defflavor x-error () (global:error)) + +#+(and Genera (not ansi-common-lisp)) +(scl:defflavor x-error + ((dbg:proceed-types '(:continue)) ; + continue-format-string) + (sys:error) + (:initable-instance-variables continue-format-string)) + +#+(and Genera (not ansi-common-lisp)) +(scl:defmethod (scl:make-instance x-error) (&rest ignore) + (when (not (sys:variable-boundp continue-format-string)) + (setf dbg:proceed-types (remove :continue dbg:proceed-types)))) + +#+(and Genera (not ansi-common-lisp)) +(scl:defmethod (dbg:proceed x-error :continue) () + :continue) + +#+(and Genera (not ansi-common-lisp)) +(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream) + (format stream continue-format-string)) + +#+(or ansi-common-lisp excl lcl3.0) +(define-condition x-error (error)) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defstruct x-error + report-function) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defun reporter-for-condition (name) + (xintern "." name '-reporter.)) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defmacro define-condition (name parents &body options) + ;; Define a structure that when printed displays an error message + (let ((slots (pop options)) + (documentation nil) + (conc-name (concatenate 'string (string name) "-")) + (reporter nil) + (condition (gensym)) + (stream (gensym)) + (report-function (reporter-for-condition name))) + (dolist (item options) + (ecase (first item) + (:documentation (setq documentation (second item))) + (:conc-name (setq conc-name (string (second item)))) + (:report (setq reporter (second item))))) + (unless reporter (setq report-function (reporter-for-condition (car parents)))) + `(within-definition (,name define-condition) + (defstruct (,name (:conc-name ,(intern conc-name)) + (:print-function condition-print) + (:include ,(car parents) (report-function ',report-function))) + ,@slots) + ,(when documentation + `(setf (documentation name 'type) ,documentation)) + ,(when reporter + `(defun ,report-function (,condition ,stream) + ,(if (stringp reporter) + `(write-string ,reporter ,stream) + `(,reporter ,condition ,stream)) + ,condition)) + ',name))) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defun condition-print (condition stream depth) + (declare (type x-error condition) + (type stream stream) + (ignore depth)) + (if *print-escape* + (print-unreadable-object (condition stream :type t)) + (funcall (x-error-report-function condition) condition stream)) + condition) + +#-(or lispm ansi-common-lisp excl lcl3.0) +(defun make-condition (type &rest slot-initializations) + (declare (dynamic-extent slot-initializations)) + (let ((make-function (intern (concatenate 'string (string 'make-) (string type)) + (symbol-package type)))) + (apply make-function slot-initializations))) + +#-(or ansi-common-lisp excl lcl3.0) +(define-condition type-error (x-error) + (datum + expected-type) + (:report (lambda (condition stream) + (format stream "~s isn't a ~a" + (type-error-datum condition) + (type-error-expected-type condition))))) + + +;;----------------------------------------------------------------------------- +;; HOST hacking +;;----------------------------------------------------------------------------- + +#-(or explorer Genera) +(defun host-address (host &optional (family :internet)) + ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type (or stringable list) host) + (type (or null (member :internet :decnet :chaos) card8) family)) + (declare (values list)) + host family + (error "HOST-ADDRESS not implemented yet.")) + +#+explorer +(defun host-address (host &optional (family :internet)) + ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type (or stringable list) host) + (type (or null (member :internet :decnet :chaos) card8) family)) + (declare (values list)) + (ecase family + (:internet + (let ((addr (ip:get-ip-address host))) + (unless addr (error "~s isn't an internet host name" host)) + (list :internet + (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr)))) + (:chaos + (let ((addr (first (chaos:chaos-addresses host)))) + (unless addr (error "~s isn't a chaos host name" host)) + (list :chaos + (ldb (byte 8 0) addr) + (ldb (byte 8 8) addr)))))) + +#+Genera +(defun host-address (host &optional (family :internet)) + ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type (or stringable list) host) + (type (or null (member :internet :decnet :chaos) card8) family)) + (declare (values list)) + (let ((net-type (if (eq family :DECnet) + :DNA + family))) + (dolist (addr + (sys:send (net:parse-host host) :network-addresses) + (error "~s isn't a valid ~(~A~) host name" host family)) + (let ((network (car addr)) + (address (cadr addr))) + (when (sys:send network :network-typep net-type) + (return (ecase family + (:internet + (multiple-value-bind (a b c d) (tcp:explode-internet-address address) + (list :internet a b c d))) + ((:chaos :DECnet) + (list family (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) + +#+explorer ;; This isn't required, but it helps make sense of the results from access-hosts +(defun get-host (host-object) + ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type list host-object)) + (declare (values string family)) + (let* ((family (first host-object)) + (address (ecase family + (:internet + (dpb (second host-object) + (byte 8 24) + (dpb (third host-object) + (byte 8 16) + (dpb (fourth host-object) + (byte 8 8) + (fifth host-object))))) + (:chaos + (dpb (third host-object) (byte 8 8) (second host-object)))))) + (when (eq family :internet) (setq family :ip)) + (let ((host (si:get-host-from-address address family))) + (values (and host (funcall host :name)) family)))) + +;;; This isn't required, but it helps make sense of the results from access-hosts +#+Genera +(defun get-host (host-object) + ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) + ;; and cdr is a list of network address bytes. + (declare (type list host-object)) + (declare (values string family)) + (let ((family (first host-object))) + (values (sys:send (net:get-host-from-address + (ecase family + (:internet + (apply #'tcp:build-internet-address (rest host-object))) + ((:chaos :DECnet) + (dpb (third host-object) (byte 8 8) (second host-object)))) + (net:local-network-of-type (if (eq family :DECnet) + :DNA + family))) + :name) + family))) + + +;;----------------------------------------------------------------------------- +;; Whether to use closures for requests or not. +;;----------------------------------------------------------------------------- + +;;; If this macro expands to non-NIL, then request and locking code is +;;; compiled in a much more compact format, as the common code is shared, and +;;; the specific code is built into a closure that is funcalled by the shared +;;; code. If your compiler makes efficient use of closures then you probably +;;; want to make this expand to T, as it makes the code more compact. + +(defmacro use-closures () + #+lispm t #-lispm nil) + + +;;----------------------------------------------------------------------------- +;; Resource stuff +;;----------------------------------------------------------------------------- + + +;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if +;;; a resource manager isn't running. + +(defun default-resources-pathname () + (when #+unix t #-unix (search "Unix" (software-type) :test #'char-equal) + (merge-pathnames (user-homedir-pathname) (pathname ".Xdefaults")))) + + + +;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the +;;; defaults have been loaded. + +(defun resources-pathname () + (when #+unix t #-unix (search "Unix" (software-type) :test #'char-equal) + (or #+(or excl lcl3.0) + (let ((string (#+excl sys:getenv + #+lcl3.0 lcl:environment-variable + "XENVIRONMENT"))) + (when string + (pathname string))) + (merge-pathnames + (user-homedir-pathname) + (pathname + (concatenate 'simple-string ".Xdefaults-" + #+excl (short-site-name) + #-excl (machine-instance))))))) + + +;;----------------------------------------------------------------------------- +;; GC stuff +;;----------------------------------------------------------------------------- + +#+Genera +(si:define-gc-cleanup clx-cleanup ("CLX Cleanup") + (declare (special *event-free-list* + *pending-command-free-list* + *reply-buffer-free-lists* + *gcontext-local-state-cache* + *temp-gcontext-cache*)) + (setq *event-free-list* nil) + (setq *pending-command-free-list* nil) + (fill *reply-buffer-free-lists* nil) + (setq *gcontext-local-state-cache* nil) + (setq *temp-gcontext-cache* nil)) + + +;;----------------------------------------------------------------------------- +;; Image stuff +;;----------------------------------------------------------------------------- + +(deftype pixarray-1-element-type () + 'bit) + +(deftype pixarray-4-element-type () + 'card4) + +(deftype pixarray-8-element-type () + 'card8) + +(deftype pixarray-16-element-type () + 'card16) + +(deftype pixarray-24-element-type () + #-Genera 'card24 #+Genera 'int32) + +(deftype pixarray-32-element-type () + #-Genera 'card32 #+Genera 'int32) + +(deftype pixarray-1 () + '(array pixarray-1-element-type (* *))) + +(deftype pixarray-4 () + '(array pixarray-4-element-type (* *))) + +(deftype pixarray-8 () + '(array pixarray-8-element-type (* *))) + +(deftype pixarray-16 () + '(array pixarray-16-element-type (* *))) + +(deftype pixarray-24 () + '(array pixarray-24-element-type (* *))) + +(deftype pixarray-32 () + '(array pixarray-32-element-type (* *))) + +(deftype pixarray () + '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) + +(deftype bitmap () + 'pixarray-1) + + +;;; These are used to read and write pixels from and to CARD8s. + +;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. + +(defmacro read-image-load-byte (size position integer) + `(the (unsigned-byte ,size) + (#-Genera ldb #+Genera sys:%logldb + (byte ,size ,(if *image-bit-lsb-first-p* position (- 7 position))) + (the card8 ,integer)))) + +;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from +;;; the appropriate number of CARD8s. + +(defmacro read-image-assemble-bytes (&rest bytes) + (let* ((bytes (if *image-byte-lsb-first-p* bytes (reverse bytes))) + (it (first bytes)) + (count 0)) + (dolist (byte (rest bytes)) + (setq it + `(#-Genera dpb #+Genera sys:%logdpb + (the card8 ,byte) + (byte 8 ,(incf count 8)) + (the (unsigned-byte ,count) ,it)))) + #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) + #+Genera it)) + +;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit +;;; pixel. + +(defmacro write-image-load-byte (position integer integer-size) + integer-size + `(the card8 + (#-Genera ldb #+Genera sys:%logldb + (byte 8 ,(if *image-byte-lsb-first-p* + position + (- integer-size 8 position))) + #-Genera (the (unsigned-byte ,integer-size) ,integer) + #+Genera ,integer + ))) + +;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit +;;; pixels. + +(defmacro write-image-assemble-bytes (&rest bytes) + (let* ((bytes (if *image-bit-lsb-first-p* bytes (reverse bytes))) + (size (floor 8 (length bytes))) + (it (first bytes)) + (count 0)) + (dolist (byte (rest bytes)) + (setq it `(#-Genera dpb #+Genera sys:%logdpb + (the (unsigned-byte ,size) ,byte) + (byte ,size ,(incf count size)) + (the (unsigned-byte ,count) ,it)))) + `(the card8 ,it))) + +;;; If you can write fast routines that can read and write pixarrays out of a +;;; buffer-bytes, do it! It makes the image code a lot faster. The +;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines +;;; return T if they can do it, NIL if they can't. + +;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 8)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-bits (index-mod (index- x) 8)) + (right-bits (index-mod (index- width left-bits) 8)) + (middle-bits (index- width left-bits right-bits)) + (middle-bytes (index-floor middle-bits 8))) + ((index>= y height)) + (declare (type (simple-array pixarray-1-element-type (*)) vector) + (type array-index start y + left-bits right-bits middle-bits middle-bytes)) + (cond ((index< middle-bits 0) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (when (index> right-bits 6) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte))) + (when (and (index> left-bits 1) + (index> right-bits 5)) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte))) + (when (and (index> left-bits 2) + (index> right-bits 4)) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte))) + (when (and (index> left-bits 3) + (index> right-bits 3)) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte))) + (when (and (index> left-bits 4) + (index> right-bits 2)) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte))) + (when (and (index> left-bits 5) + (index> right-bits 1)) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte))) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte))))) + (t + (unless (index-zerop left-bits) + (let ((byte (aref buffer-bbuf (index1- start))) + (x (array-row-major-index array y left-bits))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index- x 1)) + (read-image-load-byte 1 7 byte)) + (when (index> left-bits 1) + (setf (aref vector (index- x 2)) + (read-image-load-byte 1 6 byte)) + (when (index> left-bits 2) + (setf (aref vector (index- x 3)) + (read-image-load-byte 1 5 byte)) + (when (index> left-bits 3) + (setf (aref vector (index- x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> left-bits 4) + (setf (aref vector (index- x 5)) + (read-image-load-byte 1 3 byte)) + (when (index> left-bits 5) + (setf (aref vector (index- x 6)) + (read-image-load-byte 1 2 byte)) + (when (index> left-bits 6) + (setf (aref vector (index- x 7)) + (read-image-load-byte 1 1 byte)) + )))))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-bits) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((byte (aref buffer-bbuf end)) + (x (array-row-major-index + array y (index+ left-bits middle-bits)))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (when (index> right-bits 1) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (when (index> right-bits 2) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (when (index> right-bits 3) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (when (index> right-bits 4) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> right-bits 5) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (when (index> right-bits 6) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + ))))))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (setf (aref vector (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (setf (aref vector (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (setf (aref vector (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (setf (aref vector (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (setf (aref vector (index+ x 6)) + (read-image-load-byte 1 6 byte)) + (setf (aref vector (index+ x 7)) + (read-image-load-byte 1 7 byte)))) + )))) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-nibbles (index-mod (index- x) 2)) + (right-nibbles (index-mod (index- width left-nibbles) 2)) + (middle-nibbles (index- width left-nibbles right-nibbles)) + (middle-bytes (index-floor middle-nibbles 2))) + ((index>= y height)) + (declare (type (simple-array pixarray-4-element-type (*)) vector) + (type array-index start y + left-nibbles right-nibbles middle-nibbles middle-bytes)) + (unless (index-zerop left-nibbles) + (setf (aref array y 0) + (read-image-load-byte + 4 4 (aref buffer-bbuf (index1- start))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x (array-row-major-index array y left-nibbles) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref array y (index+ left-nibbles middle-nibbles)) + (read-image-load-byte 4 0 (aref buffer-bbuf end))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref vector (index+ x 0)) + (read-image-load-byte 4 0 byte)) + (setf (aref vector (index+ x 1)) + (read-image-load-byte 4 4 byte)))) + )) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-8 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-8 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + x) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type (simple-array pixarray-8-element-type (*)) vector) + (type array-index start y)) + (do* ((end (index+ start width)) + (i start (index1+ i)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (the card8 (aref buffer-bbuf i)))))) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-16 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-16 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + (index* x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type (simple-array pixarray-16-element-type (*)) vector) + (type array-index start y)) + (do* ((end (index+ start (index* width 2))) + (i start (index+ i 2)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1))))))) + t) + +#+Genera +(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((array array) + (start (index+ index + (index* y padded-bytes-per-line) + (index* x 3)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (sys:array-register-1d array) + (type array-index start y)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (sys:%1d-aref array x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2))))))) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + (index* x 3)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type (simple-array pixarray-24-element-type (*)) vector) + (type array-index start y)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2))))))) + t) + +#+(or lcl3.0 excl) +(defun fast-read-pixarray-32 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-32 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (start (index+ index + (index* y padded-bytes-per-line) + (index* x 4)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type (simple-array pixarray-32-element-type (*)) vector) + (type array-index start y)) + (do* ((end (index+ start (index* width 4))) + (i start (index+ i 4)) + (x (array-row-major-index array y 0) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref vector x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)) + (aref buffer-bbuf (index+ i 3))))))) + t) + +(defun fast-read-pixarray (bbuf boffset pixarray + x y width height padded-bytes-per-line + bits-per-pixel) + (declare (type buffer-bytes bbuf) + (type array-index boffset + padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (progn bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel) + (or + #+lispm + (let* ((padded-bits-per-line (* padded-bytes-per-line 8)) + (padded-pixels-per-line + (floor padded-bits-per-line bits-per-pixel)) + (pixarray-padded-pixels-per-line + #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel))) + (when (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bits-per-line 32)) + (zerop (index-mod pixarray-padded-bits-per-line 32))) + (#+Genera sys:stack-let* #-Genera let* + ((dimensions (list height padded-pixels-per-line)) + (a (make-array + dimensions + :element-type (array-element-type pixarray) + :displaced-to bbuf + :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) + (sys:bitblt boole-1 width height a x y pixarray 0 0)) + t)) + #+Genera + (when (= bits-per-pixel 24) + (fast-read-pixarray-24 + bbuf boffset pixarray x y width height padded-bytes-per-line)) + #+(or lcl3.0 excl) + (funcall + (ecase bits-per-pixel + (1 #'fast-read-pixarray-1) (4 #'fast-read-pixarray-4) + (8 #'fast-read-pixarray-8) (16 #'fast-read-pixarray-16) + (24 #'fast-read-pixarray-24) (32 #'fast-read-pixarray-32)) + bbuf boffset pixarray x y width height padded-bytes-per-line) + )) + +;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (right-bits (index-mod width 8)) + (middle-bits (index- width right-bits)) + (middle-bytes (index-ceiling middle-bits 8)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-1-element-type (*)) vector) + (type array-index h y right-bits middle-bits + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((x (array-row-major-index + array y (index+ start-x middle-bits)))) + (declare (type array-index x)) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (if (index> right-bits 1) + (aref vector (index+ x 1)) + 0) + (if (index> right-bits 2) + (aref vector (index+ x 2)) + 0) + (if (index> right-bits 3) + (aref vector (index+ x 3)) + 0) + (if (index> right-bits 4) + (aref vector (index+ x 4)) + 0) + (if (index> right-bits 5) + (aref vector (index+ x 5)) + 0) + (if (index> right-bits 6) + (aref vector (index+ x 6)) + 0) + 0))))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1)) + (aref vector (index+ x 2)) + (aref vector (index+ x 3)) + (aref vector (index+ x 4)) + (aref vector (index+ x 5)) + (aref vector (index+ x 6)) + (aref vector (index+ x 7))))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (right-nibbles (index-mod width 2)) + (middle-nibbles (index- width right-nibbles)) + (middle-bytes (index-ceiling middle-nibbles 2)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-4-element-type (*)) vector) + (type array-index h y right-nibbles middle-nibbles + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x (array-row-major-index array y start-x) (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ start-x middle-nibbles)) + 0)))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref vector (index+ x 0)) + (aref vector (index+ x 1))))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-8 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-8 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-8-element-type (*)) vector) + (type array-index h y start)) + (do* ((end (index+ start width)) + (i start (index1+ i)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref buffer-bbuf i) (the card8 (aref vector x)))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-16 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-16 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-16-element-type (*)) vector) + (type array-index h y start)) + (do* ((end (index+ start (index* width 2))) + (i start (index+ i 2)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref vector x))) + (declare (type pixarray-16-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 16)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 16)))))) + t) + +#+Genera +(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((array array) + (h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (sys:array-register-1d array) + (type array-index y start)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (sys:%1d-aref array x))) + (declare (type pixarray-24-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 24)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 24)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 24)))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-24-element-type (*)) vector) + (type array-index y start)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref vector x))) + (declare (type pixarray-24-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 24)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 24)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 24)))))) + t) + +#+(or lcl3.0 excl) +(defun fast-write-pixarray-32 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-32 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((vector (underlying-simple-vector array)) + (h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type (simple-array pixarray-32-element-type (*)) vector) + (type array-index h y start)) + (do* ((end (index+ start (index* width 4))) + (i start (index+ i 4)) + (x (array-row-major-index array y x) (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref vector x))) + (declare (type pixarray-32-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 32)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 32)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 32)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 24 pixel 32)))))) + t) + +(defun fast-write-pixarray (bbuf boffset pixarray x y width height + padded-bytes-per-line bits-per-pixel) + (declare (type buffer-bytes bbuf) + (type pixarray pixarray) + (type card16 x y width height) + (type array-index boffset padded-bytes-per-line) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (progn bbuf boffset pixarray x y width height padded-bytes-per-line + bits-per-pixel) + (or + #+lispm + (let* ((padded-bits-per-line (* padded-bytes-per-line 8)) + (padded-pixels-per-line + (floor padded-bits-per-line bits-per-pixel)) + (pixarray-padded-pixels-per-line + #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel))) + (when (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod padded-bits-per-line 32)) + (zerop (index-mod pixarray-padded-bits-per-line 32))) + (#+Genera sys:stack-let* #-Genera let* + ((dimensions (list height padded-pixels-per-line)) + (a (make-array + dimensions + :element-type (array-element-type pixarray) + :displaced-to bbuf + :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) + (sys:bitblt boole-1 width height pixarray x y a 0 0)) + t)) + #+Genera + (when (= bits-per-pixel 24) + (fast-write-pixarray-24 + bbuf boffset pixarray x y width height padded-bytes-per-line)) + #+(or lcl3.0 excl) + (funcall + (ecase bits-per-pixel + (1 #'fast-write-pixarray-1) (4 #'fast-write-pixarray-4) + (8 #'fast-write-pixarray-8) (16 #'fast-write-pixarray-16) + (24 #'fast-write-pixarray-24) (32 #'fast-write-pixarray-32)) + bbuf boffset pixarray x y width height padded-bytes-per-line) + )) + +;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another + +(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) + (declare (type pixarray pixarray copy) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (progn pixarray copy x y width height bits-per-pixel) + (or + #+lispm + (let* ((pixarray-padded-pixels-per-line + #+Genera (sys:array-row-span pixarray) + #-Genera (array-dimension pixarray 1)) + (pixarray-padded-bits-per-line + (* pixarray-padded-pixels-per-line bits-per-pixel)) + (copy-padded-pixels-per-line + #+Genera (sys:array-row-span copy) + #-Genera (array-dimension copy 1)) + (copy-padded-bits-per-line + (* copy-padded-pixels-per-line bits-per-pixel))) + (when (and (= (sys:array-element-size pixarray) bits-per-pixel) + (zerop (index-mod pixarray-padded-bits-per-line 32)) + (zerop (index-mod copy-padded-bits-per-line 32))) + (sys:bitblt boole-1 width height pixarray x y copy 0 0) + t)) + #+Genera + (let ((src pixarray) + (dest copy)) + (declare (sys:array-register-1d src dest)) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-idx (array-row-major-index copy dst-y 0) + (index1+ dst-idx)) + (dst-end (index+ dst-idx width)) + (src-idx (array-row-major-index pixarray src-y x) + (index1+ src-idx))) + ((index>= dst-idx dst-end)) + (declare (type array-index dst-idx src-idx dst-end)) + (setf (sys:%1d-aref dest dst-idx) + (sys:%1d-aref src src-idx)))) + t) + #+(or lcl3.0 excl) + (macrolet + ((copy (type element-type) + `(let* ((pixarray pixarray) + (copy copy) + (src (underlying-simple-vector pixarray)) + (dst (underlying-simple-vector copy))) + (declare (type ,type pixarray copy) + (type (simple-array ,element-type (*)) src dst)) + #.(declare-buffun) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-idx (array-row-major-index copy dst-y 0) + (index1+ dst-idx)) + (dst-end (index+ dst-idx width)) + (src-idx (array-row-major-index pixarray src-y x) + (index1+ src-idx))) + ((index>= dst-idx dst-end)) + (declare (type array-index dst-idx src-idx dst-end)) + (setf (aref dst dst-idx) + (the ,element-type (aref src src-idx)))))))) + (ecase bits-per-pixel + (1 (copy pixarray-1 pixarray-1-element-type)) + (4 (copy pixarray-4 pixarray-4-element-type)) + (8 (copy pixarray-8 pixarray-8-element-type)) + (16 (copy pixarray-16 pixarray-16-element-type)) + (24 (copy pixarray-24 pixarray-24-element-type)) + (32 (copy pixarray-32 pixarray-32-element-type))) + t))) diff --git a/clx/display.lisp b/clx/display.lisp new file mode 100644 index 0000000000000000000000000000000000000000..05cbcc283f587fb293f0f9bb463f3b0b5e014b71 --- /dev/null +++ b/clx/display.lisp @@ -0,0 +1,533 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +(export '( + with-display + with-event-queue + open-display + display-force-output + close-display + display-protocol-version + display-vendor + display-roots + display-motion-buffer-size + display-max-request-length + display-error-handler + display-after-function + display-invoke-after-function + display-finish-output)) + +;; +;; Resource id management +;; +(defun initialize-resource-allocator (display) + ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask + (let ((id-mask (display-resource-id-mask display))) + (unless (zerop id-mask) ;; zero mask is an error + (do ((first 0 (index1+ first)) + (mask id-mask (the mask32 (ash mask -1)))) + ((oddp mask) + (setf (display-resource-id-byte display) + (byte (integer-length mask) first))) + (declare (type array-index first) + (type mask32 mask)))))) + +(defun resourcealloc (display) + ;; Allocate a resource-id for in DISPLAY + (declare (type display display)) + (declare (values resource-id)) + (dpb (incf (display-resource-id-count display)) + (display-resource-id-byte display) + (display-resource-id-base display))) + +(defmacro allocate-resource-id (display object type) + ;; Allocate a resource-id for OBJECT in DISPLAY + (declare (type display display) + (type t object)) + (declare (values resource-id)) + (if (member (eval type) *clx-cached-types*) + `(let ((id (funcall (display-xid ,display) ,display))) + (save-id ,display id ,object) + id) + `(funcall (display-xid ,display) ,display))) + +(defmacro deallocate-resource-id (display id type) + ;; Deallocate a resource-id for OBJECT in DISPLAY + (when (member (eval type) *clx-cached-types*) + `(deallocate-resource-id-internal ,display ,id))) + +(defun deallocate-resource-id-internal (display id) + (remhash id (display-resource-id-map display))) + +(defun lookup-resource-id (display id) + ;; Find the object associated with resource ID + (gethash id (display-resource-id-map display))) + +(defun save-id (display id object) + ;; Register a resource-id from another display. + (declare (type display display) + (type integer id) + (type t object)) + (declare (values object)) + (setf (gethash id (display-resource-id-map display)) object)) + +;; Define functions to find the CLX data types given a display and resource-id +;; If the data type is being cached, look there first. +(macrolet ((generate-lookup-functions (useless-name &body types) + `(within-definition (,useless-name generate-lookup-functions) + ,@(mapcar + #'(lambda (type) + `(defun ,(xintern 'lookup- type) + (display id) + (declare (type display display) + (type resource-id id)) + (declare (values ,type)) + ,(if (member type *clx-cached-types*) + `(let ((,type (lookup-resource-id display id))) + (cond ((null ,type) ;; Not found, create and save it. + (setq ,type (,(xintern 'make- type) + :display display :id id)) + (save-id display id ,type)) + ;; Found. Check the type + ,(cond ((null *type-check?*) + `(t ,type)) + ((member type '(window pixmap)) + `((type? ,type 'drawable) ,type)) + (t `((type? ,type ',type) ,type))) + ,@(when *type-check?* + `((t (x-error 'lookup-error + :id id + :display display + :type ',type + :object ,type)))))) + ;; Not being cached. Create a new one each time. + `(,(xintern 'make- type) + :display display :id id)))) + types)))) + (generate-lookup-functions ignore + drawable + window + pixmap + gcontext + cursor + colormap + font)) + +(defun id-atom (id display) + ;; Return the cached atom for an atom ID + (declare (type resource-id id) + (type display display)) + (declare (values (or null keyword))) + (gethash id (display-atom-id-map display))) + +(defun atom-id (atom display) + ;; Return the ID for an atom in DISPLAY + (declare (type xatom atom) + (type display display)) + (declare (values (or null resource-id))) + (gethash (if (keywordp atom) + atom + (kintern atom)) + (display-atom-cache display))) + +(defun set-atom-id (atom display id) + ;; Set the ID for an atom in DISPLAY + (declare (type xatom atom) + (type display display) + (type resource-id id)) + (declare (values resource-id)) + (let ((atom (if (keywordp atom) atom (kintern atom)))) + (declare (type keyword atom)) + (setf (gethash id (display-atom-id-map display)) atom) + (setf (gethash atom (display-atom-cache display)) id) + id)) + +(defsetf atom-id set-atom-id) + +(defun initialize-predefined-atoms (display) + (do ((i 1 (1+ i)) + (end (length *predefined-atoms*))) + ((>= i end)) + (declare (type resource-id i)) + (setf (atom-id (svref *predefined-atoms* i) display) i))) + +(defun visual-info (display visual-id) + (declare (type display display) + (type resource-id visual-id) + (values visual-info)) + (when (zerop visual-id) + (return-from visual-info nil)) + (dolist (screen (display-roots display)) + (declare (type screen screen)) + (dolist (depth (screen-depths screen)) + (declare (type cons depth)) + (dolist (visual-info (rest depth)) + (declare (type visual-info visual-info)) + (when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info)) + (return-from visual-info visual-info))))) + (error "Visual info not found for id #x~x in display ~s." visual-id display)) + + +;; +;; Display functions +;; +(defmacro with-display ((display &key timeout inline) + &body body) + ;; This macro is for use in a multi-process environment. It provides exclusive + ;; access to the local display object for multiple request generation. It need not + ;; provide immediate exclusive access for replies; that is, if another process is + ;; waiting for a reply (while not in a with-display), then synchronization need not + ;; (but can) occur immediately. Except where noted, all routines effectively + ;; contain an implicit with-display where needed, so that correct synchronization + ;; is always provided at the interface level on a per-call basis. Nested uses of + ;; this macro will work correctly. This macro does not prevent concurrent event + ;; processing; see with-event-queue. + `(with-buffer (,display + ,@(and timeout `(:timeout ,timeout)) + ,@(and inline `(:inline ,inline))) + ,@body)) + +(defmacro with-event-queue ((display &key timeout inline) + &body body &environment env) + ;; exclusive access to event queue + `(macrolet ((with-event-queue ((display &key timeout) &body body) + ;; Speedup hack for lexically nested with-event-queues + `(progn + (progn ,display ,@(and timeout `(,timeout)) nil) + ,@body))) + ,(if (and (null inline) (macroexpand '(use-closures) env)) + `(flet ((.with-event-queue-body. () ,@body)) + #+ansi-common-lisp + (declare (dynamic-extent #'.with-event-queue-body.)) + (with-event-queue-function + ,display ,timeout #'.with-event-queue-body.)) + (let ((disp (if (or (symbolp display) (constantp display)) + display + '.display.))) + `(let (,@(unless (eq disp display) `((,disp ,display)))) + (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock" + ,@(and timeout `(:timeout ,timeout))) + ,@body)))))) + +(defun with-event-queue-function (display timeout function) + (declare (type display display) + (type (or null number) timeout) + (type function function) + (downward-funarg function)) + (with-event-queue (display :timeout timeout :inline t) + (funcall function))) + +(defmacro with-event-queue-internal ((display &key timeout) &body body) + ;; exclusive access to the internal event queues + (let ((disp (if (or (symbolp display) (constantp display)) display '.display.))) + `(let (,@(unless (eq disp display) `((,disp ,display)))) + (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock" + ,@(and timeout `(:timeout ,timeout))) + ,@body)))) + +(defun open-display (host &rest options &key (display 0) protocol + authorization-name authorization-data &allow-other-keys) + ;; Implementation specific routine to setup the buffer for a specific host and display. + ;; This must interface with the local network facilities, and will probably do special + ;; things to circumvent the nework when displaying on the local host. + ;; + ;; A string must be acceptable as a host, but otherwise the possible types + ;; for host and protocol are not constrained, and will likely be very + ;; system dependent. The default protocol is system specific. Authorization, + ;; if any, is assumed to come from the environment somehow. + (declare (type integer display) + (dynamic-extent options)) + (declare (values display)) + ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. + (let* ((stream (open-x-stream host display protocol)) + (disp (apply #'make-buffer + #x2000 'make-display-internal + :host host + :display display + :output-stream stream + :input-stream stream + :allow-other-keys t + options)) + (ok-p nil)) + (unwind-protect + (progn + (display-connect disp + :authorization-name authorization-name + :authorization-data authorization-data) + (initialize-resource-allocator disp) + (initialize-predefined-atoms disp) + (initialize-extensions disp) + (setq ok-p t)) + (unless ok-p (close-display disp :abort t))) + disp)) + +(defun display-force-output (display) + ; Output is normally buffered, this forces any buffered output to the server. + (declare (type display display)) + (with-display (display) + (buffer-force-output display))) + +(defun close-display (display &key abort) + ;; Close the host connection in DISPLAY + (declare (type display display)) + (close-buffer display :abort abort)) + +(defun display-connect (display &key authorization-name authorization-data) + (unless authorization-name (setq authorization-name "")) + (unless authorization-data (setq authorization-data "")) + (with-buffer-output (display :sizes (8 16)) + (card8-put + 0 + (ecase (display-byte-order display) + (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First + (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First + (card16-put 2 *protocol-major-version*) + (card16-put 4 *protocol-minor-version*) + (card16-put 6 (length authorization-name)) + (card16-put 8 (length authorization-data)) + (write-sequence-char display 12 authorization-name) + (write-sequence-char display + (lround (+ 12 (length authorization-name))) authorization-data)) + (buffer-force-output display) + (let ((reply-buffer nil)) + (declare (type (or null reply-buffer) reply-buffer)) + (unwind-protect + (progn + (setq reply-buffer (allocate-reply-buffer #x1000)) + (with-buffer-input (reply-buffer :sizes (8 16 32)) + (buffer-input display buffer-bbuf 0 8) + (let ((success (boolean-get 0)) + (reason-length (card8-get 1)) + (major-version (card16-get 2)) + (minor-version (card16-get 4)) + (total-length (card16-get 6)) + vendor-length + num-roots + num-formats) + (declare (ignore total-length)) + (unless success + (x-error 'connection-failure + :major-version major-version + :minor-version minor-version + :host (display-host display) + :display (display-display display) + :reason + (progn (buffer-input display buffer-bbuf 0 reason-length) + (string-get reason-length 0 :reply-buffer reply-buffer)))) + (buffer-input display buffer-bbuf 0 32) + (setf (display-protocol-major-version display) major-version) + (setf (display-protocol-minor-version display) minor-version) + (setf (display-release-number display) (card32-get 0)) + (setf (display-resource-id-base display) (card32-get 4)) + (setf (display-resource-id-mask display) (card32-get 8)) + (setf (display-motion-buffer-size display) (card32-get 12)) + (setq vendor-length (card16-get 16)) + (setf (display-max-request-length display) (card16-get 18)) + (setq num-roots (card8-get 20)) + (setq num-formats (card8-get 21)) + ;; Get the image-info + (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) + (let ((format (display-bitmap-format display))) + (declare (type bitmap-format format)) + (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) + (setf (bitmap-format-unit format) (card8-get 24)) + (setf (bitmap-format-pad format) (card8-get 25))) + (setf (display-min-keycode display) (card8-get 26)) + (setf (display-max-keycode display) (card8-get 27)) + ;; 4 bytes unused + ;; Get the vendor string + (buffer-input display buffer-bbuf 0 (lround vendor-length)) + (setf (display-vendor-name display) + (string-get vendor-length 0 :reply-buffer reply-buffer)) + ;; Initialize the pixmap formats + (dotimes (i num-formats) ;; loop gathering pixmap formats + (buffer-input display buffer-bbuf 0 8) + (push (make-pixmap-format :depth (card8-get 0) + :bits-per-pixel (card8-get 1) + :scanline-pad (card8-get 2)) + ; 5 unused bytes + (display-pixmap-formats display))) + (setf (display-pixmap-formats display) + (nreverse (display-pixmap-formats display))) + ;; Initialize the screens + (dotimes (i num-roots) + (buffer-input display buffer-bbuf 0 40) + (let* ((root (make-window :id (card32-get 0) :display display)) + (root-visual (card32-get 32)) + (default-colormap + (make-colormap :id (card32-get 4) + :display display)) + (screen + (make-screen + :root root + :default-colormap default-colormap + :white-pixel (card32-get 8) + :black-pixel (card32-get 12) + :event-mask-at-open (card32-get 16) + :width (card16-get 20) + :height (card16-get 22) + :width-in-millimeters (card16-get 24) + :height-in-millimeters (card16-get 26) + :min-installed-maps (card16-get 28) + :max-installed-maps (card16-get 30) + :backing-stores (member8-get 36 :never :when-mapped :always) + :save-unders-p (boolean-get 37) + :root-depth (card8-get 38))) + (num-depths (card8-get 39)) + (depths nil)) + ;; Save root window for event reporting + (save-id display (window-id root) root) + ;; Create the depth AList for a screen, (depth . visual-infos) + (dotimes (j num-depths) + (buffer-input display buffer-bbuf 0 8) + (let ((depth (card8-get 0)) + (num-visuals (card16-get 2)) + (visuals nil)) ;; 4 bytes unused + (dotimes (k num-visuals) + (buffer-input display buffer-bbuf 0 24) + (let* ((visual (card32-get 0)) + (visual-info (make-visual-info + :id visual + :display display + :class (member8-get 4 :static-gray :gray-scale + :static-color :pseudo-color + :true-color :direct-color) + :bits-per-rgb (card8-get 5) + :colormap-entries (card16-get 6) + :red-mask (card32-get 8) + :green-mask (card32-get 12) + :blue-mask (card32-get 16) + ;; 4 bytes unused + ))) + (push visual-info visuals) + (when (funcall (resource-id-map-test) root-visual visual) + (setf (screen-root-visual-info screen) + (setf (colormap-visual-info default-colormap) + visual-info))))) + (push (cons depth (nreverse visuals)) depths))) + (setf (screen-depths screen) (nreverse depths)) + (push screen (display-roots display)))) + (setf (display-roots display) (nreverse (display-roots display))) + (setf (display-default-screen display) (first (display-roots display)))))) + (when reply-buffer + (deallocate-reply-buffer reply-buffer)))) + display) + +(defun display-protocol-version (display) + (declare (type display display)) + (declare (values major minor)) + (values (display-protocol-major-version display) + (display-protocol-minor-version display))) + +(defun display-vendor (display) + (declare (type display display)) + (declare (values name release)) + (values (display-vendor-name display) + (display-release-number display))) + +(defun display-nscreens (display) + (declare (type display display)) + (length (display-roots display))) + +#+comment ;; defined by the DISPLAY defstruct +(defsetf display-error-handler (display) (handler) + ;; All errors (synchronous and asynchronous) are processed by calling an error + ;; handler in the display. If handler is a sequence it is expected to contain + ;; handler functions specific to each error; the error code is used to index the + ;; sequence, fetching the appropriate handler. Any results returned by the handler + ;; are ignored; it is assumed the handler either takes care of the error + ;; completely, or else signals. For all core errors, the keyword/value argument + ;; pairs are: + ;; :display display + ;; :error-key error-key + ;; :major integer + ;; :minor integer + ;; :sequence integer + ;; :current-sequence integer + ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and + ;; :window errors another pair is: + ;; :resource-id integer + ;; For :atom errors, another pair is: + ;; :atom-id integer + ;; For :value errors, another pair is: + ;; :value integer + ) + + ;; setf'able + ;; If defined, called after every protocol request is generated, even those inside + ;; explicit with-display's, but never called from inside the after-function itself. + ;; The function is called inside the effective with-display for the associated + ;; request. Default value is nil. Can be set, for example, to + ;; #'display-force-output or #'display-finish-output. + +(defvar *inside-display-after-function* nil) + +(defun display-invoke-after-function (display) + ; Called after every protocal request is generated + (declare (type display display)) + (when (and (display-after-function display) + (not *inside-display-after-function*)) + (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls + (funcall (display-after-function display) display)))) + +(defun display-finish-output (display) + ;; Forces output, then causes a round-trip to ensure that all possible + ;; errors and events have been received. + (declare (type display display)) + (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32)) + () + ) + ;; Report asynchronous errors here if the user wants us to. + (report-asynchronous-errors display :after-finish-output)) + +(defparameter + *request-names* + '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes" + "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow" + "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows" + "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree" + "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty" + "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner" + "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer" + "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard" + "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents" + "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents" + "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus" + "QueryKeymap" "OpenFont" "CloseFont" "QueryFont" + "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath" + "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC" + "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles" + "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane" + "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle" + "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc" + "PutImage" "GetImage" "PolyText8" "PolyText16" + "ImageText8" "ImageText16" "CreateColormap" "FreeColormap" + "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps" + "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes" + "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors" + "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor" + "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions" + "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl" + "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver" + "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl" + "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver" + "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping")) diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp new file mode 100644 index 0000000000000000000000000000000000000000..41c33a6c2fe761226ca9783caeb86e6db387426e --- /dev/null +++ b/clx/gcontext.lisp @@ -0,0 +1,994 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;;; GContext + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +;;; GContext values are usually cached locally in the GContext object. +;;; This is required because the X.11 server doesn't have any requests +;;; for getting GContext values back. +;;; +;;; GContext changes are cached until force-GContext-changes is called. +;;; All the requests that use GContext (including the GContext accessors, +;;; but not the SETF's) call force-GContext-changes. +;;; In addition, the macro WITH-GCONTEXT may be used to provide a +;;; local view if a GContext. +;;; +;;; Each GContext keeps a copy of the values the server has seen, and +;;; a copy altered by SETF, called the LOCAL-STATE (bad name...). +;;; The SETF accessors increment a timestamp in the GContext. +;;; When the timestamp in a GContext isn't equal to the timestamp in +;;; the local-state, changes have been made, and force-GContext-changes +;;; loops through the GContext and local-state, sending differences to +;;; the server, and updating GContext. +;;; +;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to +;;; a private copy. This is easy (and fast) for lisp machines, but other +;;; lisps will have problems. Fortunately, most other lisps don't care, +;;; because they don't run in a multi-processing shared-address space +;;; environment. + +(in-package :xlib) + +(export '(force-gcontext-changes + with-gcontext + create-gcontext + copy-gcontext-components + copy-gcontext + free-gcontext + + gcontext-function + gcontext-plane-mask + gcontext-foreground + gcontext-background + gcontext-line-width + gcontext-line-style + gcontext-cap-style + gcontext-join-style + gcontext-fill-style + gcontext-fill-rule + gcontext-tile + gcontext-stipple + gcontext-ts-x + gcontext-ts-y + gcontext-font + gcontext-subwindow-mode + gcontext-exposures + gcontext-clip-x + gcontext-clip-y + gcontext-clip-mask + gcontext-dashes + gcontext-arc-mode + gcontext-dash-offset + gcontext-clip-ordering + + define-gcontext-accessor + )) + +;; GContext state accessors +;; The state vector contains all card32s to speed server updating + +(eval-when (eval compile load) + +(defconstant *gcontext-fast-change-length* #.(length *gcontext-components*)) + +(macrolet ((def-gc-internals (name &rest extras) + (let ((macros nil) + (indexes nil) + (masks nil) + (index 0)) + (dolist (name *gcontext-components*) + (push `(defmacro ,(xintern 'gcontext-internal- name) (state) + `(svref ,state ,,index)) + macros) + (setf (getf indexes name) index) + (push (ash 1 index) masks) + (incf index)) + (dolist (extra extras) + (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state) + `(svref ,state ,,index)) + macros) + ;; don't override already correct index entries + (unless (or (getf indexes (second extra)) (getf indexes (first extra))) + (setf (getf indexes (or (second extra) (first extra))) index)) + (push (logior (ash 1 index) + (if (second extra) + (ash 1 (position (second extra) *gcontext-components*)) + 0)) + masks) + (incf index)) + `(within-definition (def-gc-internals ,name) + ,@(nreverse macros) + (eval-when (eval compile load) + (defconstant *gcontext-data-length* ,index) + (defconstant *gcontext-indexes* ',indexes) + (defconstant *gcontext-masks* + ',(coerce (nreverse masks) 'simple-vector))))))) + (def-gc-internals ignore + (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))) + +) ;; end EVAL-WHEN + +(deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*)) + +(deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*)) + +(defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named + (name nil :type symbol :read-only t) + (default nil :type t :read-only t) + (set-function #'identity :type (function (gcontext t) t) :read-only t) + (copy-function #'identity :type (function (gcontext gcontext t) t) :read-only t)) + +(defvar *gcontext-extensions* nil) ;; list of gcontext-extension + +;; Gcontext state Resource +(defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states + +(defmacro gcontext-state-next (state) + `(svref ,state 0)) + +(defun allocate-gcontext-state () + ;; Allocate a gcontext-state + ;; Loop until a local state is found that's large enough to hold + ;; any extensions that may exist. + (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*)))) + (declare (type array-index length)) + (loop + (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache* + gcontext-state-next gcontext-state) + (make-array length :initial-element nil)))) + (declare (type gcontext-state state)) + (when (index>= (length state) length) + (return state)))))) + +(defun deallocate-gcontext-state (state) + (declare (type gcontext-state state)) + (fill state nil) + (threaded-atomic-push state *gcontext-local-state-cache* + gcontext-state-next gcontext-state)) + +;; Temp-Gcontext Resource +(defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts + +(defun allocate-temp-gcontext () + (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext) + (make-gcontext :local-state '#() :server-state '#()))) + +(defun deallocate-temp-gcontext (gc) + (declare (type gcontext gc)) + (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext)) + +;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared +;; as (type <type> <name>), there is an accessor: + +;(defun gcontext-<name> (gcontext) +; ;; The value will be nil if the last value stored is unknown (e.g., the cache was +; ;; off, or the component was copied from a gcontext with unknown state). +; (declare (type gcontext gcontext) +; (values <type>))) + +;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared +;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor: + +;(defsetf gcontext-<name> (gcontext) (value) +; ) + +;; Generate all the accessors and defsetf's for GContext + +(defmacro xgcmask->gcmask (mask) + `(the gcmask (logand ,mask #.(1- (ash 1 *gcontext-fast-change-length*))))) + +(defmacro access-gcontext ((gcontext local-state) &body body) + `(let ((,local-state (gcontext-local-state ,gcontext))) + (declare (type gcontext-state ,local-state)) + ,@body)) + +(defmacro modify-gcontext ((gcontext local-state) &body body) + ;; The timestamp must be altered after the modification + `(let ((,local-state (gcontext-local-state ,gcontext))) + (declare (type gcontext-state ,local-state)) + (prog1 + (progn ,@body) + (setf (gcontext-internal-timestamp ,local-state) 0)))) + +(defmacro def-gc-accessor (name type) + (let* ((gcontext-name (xintern 'gcontext- name)) + (internal-accessor (xintern 'gcontext-internal- name)) + (internal-setfer (xintern 'set- gcontext-name))) + `(within-definition (,name def-gc-accessor) + + (defun ,gcontext-name (gcontext) + (declare (type gcontext gcontext)) + (declare (values (or null ,type))) + (let ((value (,internal-accessor (gcontext-local-state gcontext)))) + (declare (type (or null card32) value)) + (when value ;; Don't do anything when value isn't known + (let ((%buffer (gcontext-display gcontext))) + (declare (type display %buffer)) + %buffer + (decode-type ,type value))))) + + (defun ,internal-setfer (gcontext value) + (declare (type gcontext gcontext) + (type ,type value)) + (modify-gcontext (gcontext local-state) + (setf (,internal-accessor local-state) (encode-type ,type value)) + ,@(when (eq type 'pixmap) + ;; write-through pixmaps, because the protocol allows + ;; the server to copy the pixmap contents at the time + ;; of the store, rather than continuing to share with + ;; the pixmap. + `((let ((server-state (gcontext-server-state gcontext))) + (setf (,internal-accessor server-state) nil)))) + value)) + + (defsetf ,gcontext-name ,internal-setfer)))) + +(defmacro incf-internal-timestamp (state) + (let ((ts (gensym))) + `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state)))) + (declare (type fixnum ,ts)) + ;; the probability seems low enough + (setq ,ts (if (= ,ts most-positive-fixnum) + 1 + (the fixnum (1+ ,ts)))) + (setf (gcontext-internal-timestamp ,state) ,ts)))) + +(def-gc-accessor function boole-constant) +(def-gc-accessor plane-mask card32) +(def-gc-accessor foreground card32) +(def-gc-accessor background card32) +(def-gc-accessor line-width card16) +(def-gc-accessor line-style (member :solid :dash :double-dash)) +(def-gc-accessor cap-style (member :not-last :butt :round :projecting)) +(def-gc-accessor join-style (member :miter :round :bevel)) +(def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled)) +(def-gc-accessor fill-rule (member :even-odd :winding)) +(def-gc-accessor tile pixmap) +(def-gc-accessor stipple pixmap) +(def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin +(def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin +;; (def-GC-accessor font font) ;; See below +(def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors)) +(def-gc-accessor exposures (member :off :on)) +(def-gc-accessor clip-x int16) +(def-gc-accessor clip-y int16) +;; (def-GC-accessor clip-mask) ;; see below +(def-gc-accessor dash-offset card16) +;; (def-GC-accessor dashes) ;; see below +(def-gc-accessor arc-mode (member :chord :pie-slice)) + + +(defun gcontext-clip-mask (gcontext) + (declare (type gcontext gcontext)) + (declare (values (or null (member :none) pixmap rect-seq) + (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))) + (access-gcontext (gcontext local-state) + (multiple-value-bind (clip clip-mask) + (without-interrupts + (values (gcontext-internal-clip local-state) + (gcontext-internal-clip-mask local-state))) + (if (null clip) + (values (let ((%buffer (gcontext-display gcontext))) + (declare (type display %buffer)) + (decode-type (or (member :none) pixmap) clip-mask)) + nil) + (values (second clip) + (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) + (first clip))))))) + +(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) + ;; A bit strange, but retains setf form. + ;; a nil clip-mask is transformed to an empty vector + `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask)) + +(defun set-gcontext-clip-mask (gcontext ordering clip-mask) + ;; a nil clip-mask is transformed to an empty vector + (declare (type gcontext gcontext) + (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) + (type (or (member :none) pixmap rect-seq) clip-mask)) + (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq))) + (multiple-value-bind (clip-mask clip) + (typecase clip-mask + (pixmap (values (pixmap-id clip-mask) nil)) + ((member :none) (values 0 nil)) + (sequence + (values nil + (list (encode-type + (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) + ordering) + (copy-seq clip-mask)))) + (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))) + (modify-gcontext (gcontext local-state) + (let ((server-state (gcontext-server-state gcontext))) + (declare (type gcontext-state server-state)) + (without-interrupts + (setf (gcontext-internal-clip local-state) clip + (gcontext-internal-clip-mask local-state) clip-mask) + (if (null clip) + (setf (gcontext-internal-clip server-state) nil) + (setf (gcontext-internal-clip-mask server-state) nil)) + (when (and clip-mask (not (zerop clip-mask))) + ;; write-through clip-mask pixmap, because the protocol allows the + ;; server to copy the pixmap contents at the time of the store, + ;; rather than continuing to share with the pixmap. + (setf (gcontext-internal-clip-mask server-state) nil)))))) + clip-mask) + +(defun gcontext-dashes (gcontext) + (declare (type gcontext gcontext)) + (declare (values (or null card8 sequence))) + (access-gcontext (gcontext local-state) + (multiple-value-bind (dash dashes) + (without-interrupts + (values (gcontext-internal-dash local-state) + (gcontext-internal-dashes local-state))) + (if (null dash) + dashes + dash)))) + +(defsetf gcontext-dashes set-gcontext-dashes) + +(defun set-gcontext-dashes (gcontext dashes) + (declare (type gcontext gcontext) + (type (or card8 sequence) dashes)) + (multiple-value-bind (dashes dash) + (if (type? dashes 'sequence) + (if (zerop (length dashes)) + (x-type-error dashes '(or card8 sequence) "non-empty sequence") + (values nil (or (copy-seq dashes) (vector)))) + (values (encode-type card8 dashes) nil)) + (modify-gcontext (gcontext local-state) + (let ((server-state (gcontext-server-state gcontext))) + (declare (type gcontext-state server-state)) + (without-interrupts + (setf (gcontext-internal-dash local-state) dash + (gcontext-internal-dashes local-state) dashes) + (if (null dash) + (setf (gcontext-internal-dash server-state) nil) + (setf (gcontext-internal-dashes server-state) nil)))))) + dashes) + +(defun gcontext-font (gcontext &optional metrics-p) + ;; If the stored font is known, it is returned. If it is not known and + ;; metrics-p is false, then nil is returned. If it is not known and + ;; metrics-p is true, then a pseudo font is returned. Full metric and + ;; property information can be obtained, but the font does not have a name or + ;; a resource-id, and attempts to use it where a resource-id is required will + ;; result in an invalid-font error. + (declare (type gcontext gcontext) + (type boolean metrics-p)) + (declare (values (or null font))) + (access-gcontext (gcontext local-state) + (let ((font (gcontext-internal-font-obj local-state))) + (or font + (when metrics-p + ;; XXX this isn't correct + (make-font :display (gcontext-display gcontext) + :id (gcontext-id gcontext) + :name nil)))))) + +(defsetf gcontext-font set-gcontext-font) + +(defun set-gcontext-font (gcontext font) + (declare (type gcontext gcontext) + (type fontable font)) + (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font))) + (font (and font-object (font-id font-object)))) + ;; XXX need to check font has id (and name?) + (modify-gcontext (gcontext local-state) + (let ((server-state (gcontext-server-state gcontext))) + (declare (type gcontext-state server-state)) + (without-interrupts + (setf (gcontext-internal-font-obj local-state) font-object + (gcontext-internal-font local-state) font) + ;; check against font, not against font-obj + (if (null font) + (setf (gcontext-internal-font server-state) nil) + (setf (gcontext-internal-font-obj server-state) font-object)))))) + font) + +(defun force-gcontext-changes-internal (gcontext) + ;; Force any delayed changes. + (declare (type gcontext gcontext)) + #.(declare-buffun) + + (let ((display (gcontext-display gcontext)) + (server-state (gcontext-server-state gcontext)) + (local-state (gcontext-local-state gcontext))) + (declare (type display display) + (type gcontext-state server-state local-state)) + + ;; Update server when timestamps don't match + (unless (= (the fixnum (gcontext-internal-timestamp local-state)) + (the fixnum (gcontext-internal-timestamp server-state))) + + ;; The display is already locked. + (macrolet ((with-buffer ((buffer &key timeout) &body body) + `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) + ,@body))) + + ;; Because there is no locking on the local state we have to + ;; assume that state will change and set timestamps up front, + ;; otherwise by the time we figured out there were no changes + ;; and tried to store the server stamp as the local stamp, the + ;; local stamp might have since been modified. + (setf (gcontext-internal-timestamp local-state) + (incf-internal-timestamp server-state)) + + (block no-changes + (let ((last-request (buffer-last-request display))) + (with-buffer-request (display *x-changegc*) + (gcontext gcontext) + (progn + (do ((i 0 (index+ i 1)) + (bit 1 (the xgcmask (ash bit 1))) + (nbyte 12) + (mask 0) + (local 0)) + ((index>= i *gcontext-fast-change-length*) + (when (zerop mask) + ;; If nothing changed, restore last-request and quit + (setf (buffer-last-request display) + (if (zerop (buffer-last-request display)) + nil + last-request)) + (return-from no-changes nil)) + (card29-put 8 mask) + (card16-put 2 (index-ash nbyte -2)) + (index-incf (buffer-boffset display) nbyte)) + (declare (type array-index i nbyte) + (type xgcmask bit) + (type gcmask mask) + (type (or null card32) local)) + (unless (eql (the (or null card32) (svref server-state i)) + (setq local (the (or null card32) (svref local-state i)))) + (setf (svref server-state i) local) + (card32-put nbyte local) + (setq mask (the gcmask (logior mask bit))) + (index-incf nbyte 4))))))) + + ;; Update GContext extensions + (do ((extension *gcontext-extensions* (cdr extension)) + (i *gcontext-data-length* (index+ i 1)) + (local)) + ((endp extension)) + (unless (eql (svref server-state i) + (setq local (svref local-state i))) + (setf (svref server-state i) local) + (funcall (gcontext-extension-set-function (car extension)) gcontext local))) + + ;; Update clipping rectangles + (multiple-value-bind (local-clip server-clip) + (without-interrupts + (values (gcontext-internal-clip local-state) + (gcontext-internal-clip server-state))) + (unless (equalp local-clip server-clip) + (setf (gcontext-internal-clip server-state) nil) + (unless (null local-clip) + (with-buffer-request (display *x-setcliprectangles*) + (data (first local-clip)) + (gcontext gcontext) + ;; XXX treat nil correctly + (card16 (or (gcontext-internal-clip-x local-state) 0) + (or (gcontext-internal-clip-y local-state) 0)) + ;; XXX this has both int16 and card16 values + ((sequence :format int16) (second local-clip))) + (setf (gcontext-internal-clip server-state) local-clip)))) + + ;; Update dashes + (multiple-value-bind (local-dash server-dash) + (without-interrupts + (values (gcontext-internal-dash local-state) + (gcontext-internal-dash server-state))) + (unless (equalp local-dash server-dash) + (setf (gcontext-internal-dash server-state) nil) + (unless (null local-dash) + (with-buffer-request (display *x-setdashes*) + (gcontext gcontext) + ;; XXX treat nil correctly + (card16 (or (gcontext-internal-dash-offset local-state) 0) + (length local-dash)) + ((sequence :format card8) local-dash)) + (setf (gcontext-internal-dash server-state) local-dash)))))))) + +(defun force-gcontext-changes (gcontext) + ;; Force any delayed changes. + (declare (type gcontext gcontext)) + (let ((display (gcontext-display gcontext)) + (server-state (gcontext-server-state gcontext)) + (local-state (gcontext-local-state gcontext))) + (declare (type gcontext-state server-state local-state) + (array-register server-state local-state)) + ;; Update server when timestamps don't match + (unless (= (the fixnum (gcontext-internal-timestamp local-state)) + (the fixnum (gcontext-internal-timestamp server-state))) + (with-display (display) + (force-gcontext-changes-internal gcontext))))) + +;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE +;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN +;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN +;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS +;;; BACK. + +(defmacro with-gcontext ((gcontext &rest options &key clip-ordering + &allow-other-keys) + &body body) + ;; "Binds" the gcontext components specified by options within the + ;; dynamic scope of the body (i.e., indefinite scope and dynamic + ;; extent), on a per-process basis in a multi-process environment. + ;; The body is not surrounded by a with-display. If cache-p is nil or + ;; the some component states are unknown, this will implement + ;; save/restore by creating a temporary gcontext and doing + ;; copy-gcontext-components to and from it. + + (declare (arglist (gcontext &rest options &key + function plane-mask foreground background + line-width line-style cap-style join-style + fill-style fill-rule arc-mode tile stipple ts-x + ts-y font subwindow-mode exposures clip-x clip-y + clip-mask clip-ordering dash-offset dashes + &allow-other-keys) + &body body)) + (remf options :clip-ordering) + + (let ((gc (gensym)) + (saved-state (gensym)) + (temp-gc (gensym)) + (temp-mask (gensym)) + (temp-vars nil) + (setfs nil) + (indexes nil) ; List of gcontext field indices + (extension-indexes nil) ; List of gcontext extension field indices + (ts-index (getf *gcontext-indexes* :timestamp))) + + (do* ((option options (cddr option)) + (name (car option) (car option)) + (value (cadr option) (cadr option))) + ((endp option) (setq setfs (nreverse setfs))) + (let ((index (getf *gcontext-indexes* name))) + (if index + (push index indexes) + (let ((extension (find name *gcontext-extensions* + :key #'gcontext-extension-name))) + (if extension + (progn + (push (xintern "Internal-" 'gcontext- name "-State-Index") + extension-indexes)) + (x-type-error name 'gcontext-key))))) + (let ((accessor `(,(xintern 'gcontext- name) ,gc + ,@(when (eq name :clip-mask) `(,clip-ordering)))) + (temp-var (gensym))) + (when value + (push `(,temp-var ,value) temp-vars) + (push `(setf ,accessor ,temp-var) setfs)))) + (if setfs + `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) + (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) + (declare (type gcontext ,gc) + (type gcontext-state ,saved-state) + (type xgcmask ,temp-mask) + (type (or null resource-id) ,temp-gc)) + (with-gcontext-bindings (,gc ,saved-state + ,(append indexes extension-indexes) + ,ts-index ,temp-mask ,temp-gc) + (let ,temp-vars + ,@setfs) + ,@body)) + `(progn ,@body)))) + +(defun copy-gcontext-local-state (gcontext indexes &rest extension-indices) + ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK + (declare (type gcontext gcontext) + (type list indexes) + (dynamic-extent extension-indices)) + (let ((local-state (gcontext-local-state gcontext)) + (saved-state (allocate-gcontext-state)) + (cache-p (gcontext-cache-p gcontext))) + (declare (type gcontext-state local-state saved-state)) + (setf (gcontext-internal-timestamp saved-state) 1) + (let ((temp-gc nil) + (temp-mask 0) + (extension-mask 0)) + (declare (type xgcmask temp-mask) + (type integer extension-mask)) + (dolist (i indexes) + (when (or (not (setf (svref saved-state i) (svref local-state i))) + (not cache-p)) + (setq temp-mask + (the xgcmask (logior temp-mask + (the xgcmask (svref *gcontext-masks* i))))))) + (dolist (i extension-indices) + (when (or (not (setf (svref saved-state i) (svref local-state i))) + (not cache-p)) + (setq extension-mask + (the xgcmask (logior extension-mask (ash 1 i)))))) + (when (or (plusp temp-mask) + (plusp extension-mask)) + ;; Copy to temporary GC when field unknown or cache-p false + (let ((display (gcontext-display gcontext))) + (declare (type display display)) + (with-display (display) + (setq temp-gc (allocate-temp-gcontext)) + (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext) + (gcontext-display temp-gc) display + (gcontext-drawable temp-gc) (gcontext-drawable gcontext) + (gcontext-server-state temp-gc) saved-state + (gcontext-local-state temp-gc) saved-state) + ;; Create a new (temporary) gcontext + (with-buffer-request (display *x-creategc*) + (gcontext temp-gc) + (drawable (gcontext-drawable gcontext)) + (card29 0)) + ;; Copy changed components to the temporary gcontext + (when (plusp temp-mask) + (with-buffer-request (display *x-copygc*) + (gcontext gcontext) + (gcontext temp-gc) + (card29 (xgcmask->gcmask temp-mask)))) + ;; Copy extension fields to the new gcontext + (when (plusp extension-mask) + ;; Copy extension fields from temp back to gcontext + (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1)) + (i 0 (index+ i 1))) + ((zerop bit)) + (let ((copy-function (gcontext-extension-copy-function + (elt *gcontext-extensions* i)))) + (funcall copy-function gcontext temp-gc + (svref local-state (index+ i *gcontext-data-length*)))))) + ))) + (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) + +(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc) + (declare (type gcontext gcontext temp-gc) + (type xgcmask temp-mask)) + (let ((display (gcontext-display gcontext))) + (declare (type display display)) + (with-display (display) + (with-buffer-request (display *x-copygc*) + (gcontext temp-gc) + (gcontext gcontext) + (card29 (xgcmask->gcmask temp-mask))) + ;; Copy extension fields from temp back to gcontext + (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1)) + (extensions *gcontext-extensions* (cdr extensions)) + (i *gcontext-data-length* (index+ i 1)) + (local-state (gcontext-local-state temp-gc))) + ((zerop bit)) + (let ((copy-function (gcontext-extension-copy-function (car extensions)))) + (funcall copy-function temp-gc gcontext (svref local-state i)))) + ;; free gcontext + (with-buffer-request (display *x-freegc*) + (gcontext temp-gc)) + (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext) + (deallocate-temp-gcontext temp-gc) + ;; Copy saved state back to server state + (do ((server-state (gcontext-server-state gcontext)) + (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1))) + (i 0 (index+ i 1))) + ((zerop bit) + (incf-internal-timestamp server-state)) + (declare (type gcontext-state server-state) + (type gcmask bit) + (type array-index i)) + (when (oddp bit) + (setf (svref server-state i) nil)))))) + +(defun create-gcontext (&rest options &key (drawable (required-arg drawable)) + function plane-mask foreground background + line-width line-style cap-style join-style fill-style fill-rule + arc-mode tile stipple ts-x ts-y font subwindow-mode + exposures clip-x clip-y clip-mask clip-ordering + dash-offset dashes + (cache-p t) + &allow-other-keys) + ;; Only non-nil components are passed on in the request, but for effective caching + ;; assumptions have to be made about what the actual protocol defaults are. For + ;; all gcontext components, a value of nil causes the default gcontext value to be + ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented + ;; as a list. Note: use of stringable as font will cause an implicit open-font. + ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If + ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext + ;; component will have no effect unless the new value differs from the cached + ;; value. Component changes (setfs and with-gcontext) are always deferred + ;; regardless of the cache mode, and sent over the protocol only when required by a + ;; local operation or by an explicit call to force-gcontext-changes. + (declare (type drawable drawable) ; Required to be non-null + (type (or null boole-constant) function) + (type (or null pixel) plane-mask foreground background) + (type (or null card16) line-width dash-offset) + (type (or null int16) ts-x ts-y clip-x clip-y) + (type (or null (member :solid :dash :double-dash)) line-style) + (type (or null (member :not-last :butt :round :projecting)) cap-style) + (type (or null (member :miter :round :bevel)) join-style) + (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) + (type (or null (member :even-odd :winding)) fill-rule) + (type (or null (member :chord :pie-slice)) arc-mode) + (type (or null pixmap) tile stipple) + (type (or null fontable) font) + (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) + (type (or null (member :on :off)) exposures) + (type (or null (member :none) pixmap rect-seq) clip-mask) + (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) + (type (or null card8 sequence) dashes) + (dynamic-extent options) + (type boolean cache-p)) + (declare (values gcontext)) + (let* ((display (drawable-display drawable)) + (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p)) + (local-state (gcontext-local-state gcontext)) + (server-state (gcontext-server-state gcontext)) + (gcontextid (allocate-resource-id display gcontext 'gcontext))) + (declare (type display display) + (type gcontext gcontext) + (type resource-id gcontextid) + (type gcontext-state local-state server-state)) + (setf (gcontext-id gcontext) gcontextid) + + (unless function (setf (gcontext-function gcontext) boole-1)) + ;; using the depth of the drawable would be better, but ... + (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff)) + (unless foreground (setf (gcontext-foreground gcontext) 0)) + (unless background (setf (gcontext-background gcontext) 1)) + (unless line-width (setf (gcontext-line-width gcontext) 0)) + (unless line-style (setf (gcontext-line-style gcontext) :solid)) + (unless cap-style (setf (gcontext-cap-style gcontext) :butt)) + (unless join-style (setf (gcontext-join-style gcontext) :miter)) + (unless fill-style (setf (gcontext-fill-style gcontext) :solid)) + (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd)) + (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice)) + (unless ts-x (setf (gcontext-ts-x gcontext) 0)) + (unless ts-y (setf (gcontext-ts-y gcontext) 0)) + (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext) + :clip-by-children)) + (unless exposures (setf (gcontext-exposures gcontext) :on)) + (unless clip-mask (setf (gcontext-clip-mask gcontext) :none)) + (unless clip-x (setf (gcontext-clip-x gcontext) 0)) + (unless clip-y (setf (gcontext-clip-y gcontext) 0)) + (unless dashes (setf (gcontext-dashes gcontext) 4)) + (unless dash-offset (setf (gcontext-dash-offset gcontext) 0)) + ;; a bit kludgy, but ... + (replace server-state local-state) + + (when function (setf (gcontext-function gcontext) function)) + (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask)) + (when foreground (setf (gcontext-foreground gcontext) foreground)) + (when background (setf (gcontext-background gcontext) background)) + (when line-width (setf (gcontext-line-width gcontext) line-width)) + (when line-style (setf (gcontext-line-style gcontext) line-style)) + (when cap-style (setf (gcontext-cap-style gcontext) cap-style)) + (when join-style (setf (gcontext-join-style gcontext) join-style)) + (when fill-style (setf (gcontext-fill-style gcontext) fill-style)) + (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule)) + (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode)) + (when tile (setf (gcontext-tile gcontext) tile)) + (when stipple (setf (gcontext-stipple gcontext) stipple)) + (when ts-x (setf (gcontext-ts-x gcontext) ts-x)) + (when ts-y (setf (gcontext-ts-y gcontext) ts-y)) + (when font (setf (gcontext-font gcontext) font)) + (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode)) + (when exposures (setf (gcontext-exposures gcontext) exposures)) + (when clip-x (setf (gcontext-clip-x gcontext) clip-x)) + (when clip-y (setf (gcontext-clip-y gcontext) clip-y)) + (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask)) + (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset)) + (when dashes (setf (gcontext-dashes gcontext) dashes)) + + (setf (gcontext-internal-timestamp server-state) 1) + (setf (gcontext-internal-timestamp local-state) 1) + + (with-buffer-request (display *x-creategc*) + (resource-id gcontextid) + (drawable drawable) + (progn (do* ((i 0 (index+ i 1)) + (bit 1 (the xgcmask (ash bit 1))) + (nbyte 16) + (mask 0) + (local (svref local-state i) (svref local-state i))) + ((index>= i *gcontext-fast-change-length*) + (card29-put 12 mask) + (card16-put 2 (index-ash nbyte -2)) + (index-incf (buffer-boffset display) nbyte)) + (declare (type array-index i nbyte) + (type xgcmask bit) + (type gcmask mask) + (type (or null card32) local)) + (unless (eql local (the (or null card32) (svref server-state i))) + (setf (svref server-state i) local) + (card32-put nbyte local) + (setq mask (the gcmask (logior mask bit))) + (index-incf nbyte 4))))) + + ;; Initialize extensions + (do ((extensions *gcontext-extensions* (cdr extensions)) + (i *gcontext-data-length* (index+ i 1))) + ((endp extensions)) + (declare (type list extensions) + (type array-index i)) + (setf (svref server-state i) + (setf (svref local-state i) + (gcontext-extension-default (car extensions))))) + + ;; Set extension values + (do* ((option-list options (cddr option-list)) + (option (car option-list) (car option-list)) + (extension)) + ((endp option-list)) + (declare (type list option-list)) + (cond ((getf *gcontext-indexes* option)) ; Gcontext field + ((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter + ((setq extension (find option *gcontext-extensions* + :key #'gcontext-extension-name)) + (funcall (gcontext-extension-set-function extension) + gcontext (second option-list))) + (t (x-type-error option 'gcontext-key)))) + gcontext)) + +(defun copy-gcontext-components (src dst &rest keys) + (declare (type gcontext src dst) + (dynamic-extent keys)) + ;; you might ask why this isn't just a bunch of + ;; (setf (gcontext-<mumble> dst) (gcontext-<mumble> src)) + ;; the answer is that you can do that yourself if you want, what we are + ;; providing here is access to the protocol request, which will generally + ;; be more efficient (particularly for things like clip and dash lists). + (when keys + (let ((display (gcontext-display src)) + (mask 0)) + (declare (type xgcmask mask)) + (with-display (display) + (force-gcontext-changes-internal src) + (force-gcontext-changes-internal dst) + + ;; collect entire mask and handle extensions + (dolist (key keys) + (let ((i (getf *gcontext-indexes* key))) + (declare (type (or null array-index) i)) + (if i + (setq mask (the xgcmask (logior mask + (the xgcmask (svref *gcontext-masks* i))))) + (multiple-value-bind (extension index) + (find key *gcontext-extensions* :key #'gcontext-extension-name) + (if extension + (funcall (gcontext-extension-copy-function extension) + src dst (svref (gcontext-local-state src) + (index+ index *gcontext-data-length*))) + (x-type-error key 'gcontext-key)))))) + + (when (plusp mask) + (do ((src-server-state (gcontext-server-state src)) + (dst-server-state (gcontext-server-state dst)) + (dst-local-state (gcontext-local-state dst)) + (bit mask (the xgcmask (ash bit -1))) + (i 0 (index+ i 1))) + ((zerop bit) + (incf-internal-timestamp dst-server-state) + (setf (gcontext-internal-timestamp dst-local-state) 0)) + (declare (type gcontext-state src-server-state dst-server-state dst-local-state) + (type xgcmask bit) + (type array-index i)) + (when (oddp bit) + (setf (svref dst-local-state i) + (setf (svref dst-server-state i) (svref src-server-state i))))) + (with-buffer-request (display *x-copygc*) + (gcontext src dst) + (card29 (xgcmask->gcmask mask)))))))) + +(defun copy-gcontext (src dst) + (declare (type gcontext src dst)) + ;; Copies all components. + (apply #'copy-gcontext-components src dst *gcontext-components*) + (do ((extensions *gcontext-extensions* (cdr extensions)) + (i *gcontext-data-length* (index+ i 1))) + ((endp extensions)) + (funcall (gcontext-extension-copy-function (car extensions)) + src dst (svref (gcontext-local-state src) i)))) + +(defun free-gcontext (gcontext) + (declare (type gcontext gcontext)) + (let ((display (gcontext-display gcontext))) + (with-buffer-request (display *x-freegc*) + (gcontext gcontext)) + (deallocate-resource-id display (gcontext-id gcontext) 'gcontext) + (deallocate-gcontext-state (gcontext-server-state gcontext)) + (deallocate-gcontext-state (gcontext-local-state gcontext)) + nil)) + +(defmacro define-gcontext-accessor (name &key default set-function copy-function) + ;; This will define a new gcontext accessor called NAME. + ;; Defines the gcontext-NAME accessor function and its defsetf. + ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when + ;; gcontext-cache-p is true. The NAME keyword will be allowed in + ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS. + ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE) + ;; from create-gcontext, and force-gcontext-changes. + ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value) + ;; from copy-gcontext and copy-gcontext-components. + ;; The copy-function defaults to: + ;; (lambda (ignore dst-gc value) + ;; (if value + ;; (,set-function dst-gc value) + ;; (error "Can't copy unknown GContext component ~a" ',name))) + (declare (type symbol name) + (type t default) + (type (function (gcontext t) t) set-function) ;; required + (type (or null (function (gcontext gcontext t) t)) + copy-function)) + (let* ((gc-name (intern (concatenate 'string + (string 'gcontext-) + (string name)))) ;; in current package + (key-name (kintern name)) + (setfer (xintern "Set-" gc-name)) + (internal-set-function (xintern "Internal-Set-" gc-name)) + (internal-copy-function (xintern "Internal-Copy-" gc-name)) + (internal-state-index (xintern "Internal-" gc-name "-State-Index"))) + (unless copy-function + (setq copy-function + `(lambda (src-gc dst-gc value) + (declare (ignore src-gc)) + (if value + (,set-function dst-gc value) + (error "Can't copy unknown GContext component ~a" ',name))))) + `(progn + (eval-when (compile load eval) + (defparameter ,internal-state-index + (add-gcontext-extension ',key-name ,default ',internal-set-function + ',internal-copy-function)) + ) ;; end eval-when + (defun ,gc-name (gcontext) + (svref (gcontext-local-state gcontext) ,internal-state-index)) + (defun ,setfer (gcontext new-value) + (let ((local-state (gcontext-local-state gcontext))) + (setf (gcontext-internal-timestamp local-state) 0) + (setf (svref local-state ,internal-state-index) new-value))) + (defsetf ,gc-name ,setfer) + (defun ,internal-set-function (gcontext new-value) + (,set-function gcontext new-value) + (setf (svref (gcontext-server-state gcontext) ,internal-state-index) + (setf (svref (gcontext-local-state gcontext) ,internal-state-index) + new-value))) + (defun ,internal-copy-function (src-gc dst-gc new-value) + (,copy-function src-gc dst-gc new-value) + (setf (svref (gcontext-local-state dst-gc) ,internal-state-index) + (setf (svref (gcontext-server-state dst-gc) ,internal-state-index) + new-value))) + ',name))) + +;; GContext extension fields are treated in much the same way as normal GContext +;; components. The current value is stored in a slot of the gcontext-local-state, +;; and the value known to the server is in a slot of the gcontext-server-state. +;; The slot-number is defined by its position in the *gcontext-extensions* list. +;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is +;; the extension component name) reflects this position. The position within +;; *gcontext-extensions* and the value of the special value are determined at +;; LOAD time to facilitate merging of seperately compiled extension files. + +(defun add-gcontext-extension (name default-value set-function copy-function) + (declare (type symbol name) + (type t default-value) + (type (function (gcontext t) t) set-function) + (type (function (gcontext gcontext t) t) copy-function)) + (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name) + (prog1 (length *gcontext-extensions*) + (push nil *gcontext-extensions*))))) + (setf (nth number *gcontext-extensions*) + (make-gcontext-extension :name name + :default default-value + :set-function set-function + :copy-function copy-function)) + (+ number *gcontext-data-length*))) diff --git a/clx/image.lisp b/clx/image.lisp new file mode 100644 index 0000000000000000000000000000000000000000..152af53f8a65114e315359545afe0d0c99836fc9 --- /dev/null +++ b/clx/image.lisp @@ -0,0 +1,2697 @@ +;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- + +;;; CLX Image functions + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +(export '(bitmap + pixarray + image + image-width + image-height + image-depth + image-plist + image-name + image-x-hot + image-y-hot + image-red-mask + image-blue-mask + image-green-mask + image-x + image-xy + image-z + image-x-p + image-xy-p + image-z-p + image-xy-bitmap-list + image-z-bits-per-pixel + image-z-pixarray + create-image + get-image + put-image + copy-image + read-bitmap-file + write-bitmap-file + bitmap-image + image-pixmap)) + +(def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil)) + ;; Public structure + (width 0 :type card16 :read-only t) + (height 0 :type card16 :read-only t) + (depth 1 :type card8 :read-only t) + (plist nil :type list)) + +;; Image-Plist accessors: +(defmacro image-name (image) `(getf (image-plist ,image) :name)) +(defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot)) +(defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot)) +(defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask)) +(defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask)) +(defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask)) + +(defun print-image (image stream depth) + (declare (type image image) + (ignore depth)) + (print-unreadable-object (image stream :type t) + (when (image-name image) + (princ (image-name image) stream) + (princ " " stream)) + (prin1 (image-width image) stream) + (princ "x" stream) + (prin1 (image-height image) stream) + (princ "x" stream) + (prin1 (image-depth image) stream))) + +(defconstant *empty-data-x* #.(make-sequence '(array card8 (*)) 0)) + +(defconstant *empty-data-z* + #.(make-array '(0 0) :element-type 'pixarray-1-element-type)) + +(def-clx-class (image-x (:include image) (:copier nil) + (:print-function print-image)) + ;; Use this format for shoveling image data + ;; Private structure. Accessors for these NOT exported. + (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) + (bytes-per-line 0 :type card16) + (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) + (bit-lsb-first-p *image-bit-lsb-first-p* :type boolean) ; Bit order + (byte-lsb-first-p *image-byte-lsb-first-p* :type boolean) ; Byte order + (data *empty-data-x* :type (array card8 (*))) ; row-major + (unit *image-unit* :type (member 8 16 32)) ; Bitmap unit + (pad *image-pad* :type (member 8 16 32)) ; Scanline pad + (left-pad 0 :type card8)) ; Left pad + +(def-clx-class (image-xy (:include image) (:copier nil) + (:print-function print-image)) + ;; Public structure + ;; Use this format for image processing + (bitmap-list nil :type list)) ;; list of bitmaps + +(def-clx-class (image-z (:include image) (:copier nil) + (:print-function print-image)) + ;; Public structure + ;; Use this format for image processing + (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) + (pixarray *empty-data-z* :type pixarray)) + +(defun create-image (&key width height depth + (data (required-arg data)) + plist name x-hot y-hot + red-mask blue-mask green-mask + bits-per-pixel format bytes-per-line + (byte-lsb-first-p *image-byte-lsb-first-p*) + (bit-lsb-first-p *image-bit-lsb-first-p*) + unit pad left-pad) + ;; Returns an image-x image-xy or image-z structure, depending on the + ;; type of the :DATA parameter. + (declare + (type (or null card16) width height) ; Required + (type (or null card8) depth) ; Defualts to 1 + (type (or buffer-bytes ; Returns image-x + list ; Returns image-xy + pixarray) data) ; Returns image-z + (type list plist) + (type (or null stringable) name) + (type (or null card16) x-hot y-hot) + (type (or null pixel) red-mask blue-mask green-mask) + (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) + + ;; The following parameters are ignored for image-xy and image-z: + (type (or null (member :bitmap :xy-pixmap :z-pixmap)) + format) ; defaults to :z-pixmap + (type (or null card16) bytes-per-line) + (type boolean byte-lsb-first-p bit-lsb-first-p) + (type (or null (member 8 16 32)) unit pad) + (type (or null card8) left-pad)) + (declare (values image)) + (let ((image + (etypecase data + (buffer-bytes ; image-x + (let ((data data)) + (declare (type buffer-bytes data)) + (unless depth (setq depth (or bits-per-pixel 1))) + (unless format + (setq format (if (= depth 1) :xy-pixmap :z-pixmap))) + (unless bits-per-pixel + (setq bits-per-pixel + (cond ((eq format :xy-pixmap) 1) + ((index> depth 24) 32) + ((index> depth 16) 24) + ((index> depth 8) 16) + ((index> depth 4) 8) + ((index> depth 1) 4) + (t 1)))) + (unless width (required-arg width)) + (unless height (required-arg height)) + (unless bytes-per-line + (let* ((pad (or pad 8)) + (bits-per-line (index* width bits-per-pixel)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line pad) pad))) + (declare (type array-index pad bits-per-line + padded-bits-per-line)) + (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) + (unless unit (setq unit *image-unit*)) + (unless pad + (setq pad + (dolist (pad '(32 16 8)) + (when (and (index<= pad *image-pad*) + (zerop + (index-mod + (index* bytes-per-line 8) pad))) + (return pad))))) + (unless left-pad (setq left-pad 0)) + (make-image-x + :width width :height height :depth depth :plist plist + :format format :data data + :bits-per-pixel bits-per-pixel + :bytes-per-line bytes-per-line + :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p + :unit unit :pad pad :left-pad left-pad))) + (list ; image-xy + (let ((data data)) + (declare (type list data)) + (unless depth (setq depth (length data))) + (when data + (unless width (setq width (array-dimension (car data) 1))) + (unless height (setq height (array-dimension (car data) 0)))) + (make-image-xy + :width width :height height :plist plist :depth depth + :bitmap-list data))) + (pixarray ; image-z + (let ((data data)) + (declare (type pixarray data)) + (unless width (setq width (array-dimension data 1))) + (unless height (setq height (array-dimension data 0))) + (unless bits-per-pixel + (setq bits-per-pixel + (etypecase data + (pixarray-32 32) + (pixarray-24 24) + (pixarray-16 16) + (pixarray-8 8) + (pixarray-4 4) + (pixarray-1 1))))) + (unless depth (setq depth bits-per-pixel)) + (make-image-z + :width width :height height :depth depth :plist plist + :bits-per-pixel bits-per-pixel :pixarray data))))) + (declare (type image image)) + (when name (setf (image-name image) name)) + (when x-hot (setf (image-x-hot image) x-hot)) + (when y-hot (setf (image-y-hot image) y-hot)) + (when red-mask (setf (image-red-mask image) red-mask)) + (when blue-mask (setf (image-blue-mask image) blue-mask)) + (when green-mask (setf (image-green-mask image) green-mask)) + image)) + +;;;----------------------------------------------------------------------------- +;;; Swapping stuff + +(defun image-noswap + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p) + (ignore lsb-first-p)) + #.(declare-buffun) + (if (index= srcinc destinc) + (buffer-replace + dest src destoff + (index+ destoff (index* srcinc (index1- height)) srclen) + srcoff) + (do* ((h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc)) + (destend (index+ deststart srclen) (index+ deststart srclen))) + ((index-zerop h)) + (declare (type array-index srcstart deststart destend) + (type card16 h)) + (buffer-replace dest src deststart destend srcstart)))) + +(defun image-swap-two-bytes + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((length (index* (index-ceiling srclen 2) 2)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 2) + (if lsb-first-p + (setf (aref dest (index1+ (index+ deststart length))) + (the card8 (aref src (index+ srcstart length)))) + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index1+ (index+ srcstart length))))))) + (do ((i length (index- i 2)) + (srcidx srcstart (index+ srcidx 2)) + (destidx deststart (index+ destidx 2))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index1+ srcidx)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src srcidx)))))))) + +(defun image-swap-three-bytes + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((length (index* (index-ceiling srclen 3) 3)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 3) + (when (index= (index- srclen length) 2) + (setf (aref dest (index+ deststart length 1)) + (the card8 (aref src (index+ srcstart length 1))))) + (if lsb-first-p + (setf (aref dest (index+ deststart length 2)) + (the card8 (aref src (index+ srcstart length)))) + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index+ srcstart length 2)))))) + (do ((i length (index- i 3)) + (srcidx srcstart (index+ srcidx 3)) + (destidx deststart (index+ destidx 3))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index+ srcidx 2)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src (index1+ srcidx)))) + (setf (aref dest (index+ destidx 2)) + (the card8 (aref src srcidx)))))))) + +(defun image-swap-four-bytes + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((length (index* (index-ceiling srclen 4) 4)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 1)) + (the card8 (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 2)) + (the card8 (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 3)) + (the card8 (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index+ srcidx 3)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src (index+ srcidx 2)))) + (setf (aref dest (index+ destidx 2)) + (the card8 (aref src (index1+ srcidx)))) + (setf (aref dest (index+ destidx 3)) + (the card8 (aref src srcidx)))))))) + +(defun image-swap-words + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((length (index* (index-ceiling srclen 4) 4)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length 1)) + (the card8 (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length)) + (the card8 (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 3)) + (the card8 (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 2)) + (the card8 (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 (aref src (index+ srcidx 2)))) + (setf (aref dest (index1+ destidx)) + (the card8 (aref src (index+ srcidx 3)))) + (setf (aref dest (index+ destidx 2)) + (the card8 (aref src srcidx))) + (setf (aref dest (index+ destidx 3)) + (the card8 (aref src (index1+ srcidx))))))))) + +(defun image-swap-nibbles + (src dest srcoff destoff srclen srcinc destinc height) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index srcstart deststart) + (type card16 h)) + (do ((i srclen (index1- i)) + (srcidx srcstart (index1+ srcidx)) + (destidx deststart (index1+ destidx))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 + (let ((byte (aref src srcidx))) + (declare (type card8 byte)) + (dpb (the card4 (ldb (byte 4 0) byte)) + (byte 4 4) + (the card4 (ldb (byte 4 4) byte))))))))))) + +(defun image-swap-nibbles-left + (src dest srcoff destoff srclen srcinc destinc height) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (do ((h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index srcstart deststart) + (type card16 h)) + (do ((i srclen (index1- i)) + (srcidx srcstart (index1+ srcidx)) + (destidx deststart (index1+ destidx))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (the card8 + (let ((byte1 (aref src srcidx)) + (byte2 (aref src (index1+ srcidx)))) + (declare (type card8 byte1 byte2)) + (dpb (the card4 (ldb (byte 4 0) byte1)) + (byte 4 4) + (the card4 (ldb (byte 4 4) byte2))))))))))) + +(defconstant + *image-byte-reverse* + '#.(coerce + '#( + 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 + 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 + 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 + 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 + 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 + 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 + 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 + 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 + 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 + 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 + 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 + 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 + 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 + 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 + 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 + 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) + '(vector card8))) + +(defun image-swap-bits + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p) + (ignore lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (let ((byte-reverse *image-byte-reverse*)) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index srcstart deststart) + (type card16 h)) + (do ((i srclen (index1- i)) + (srcidx srcstart (index1+ srcidx)) + (destidx deststart (index1+ destidx))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) (br (aref src srcidx))))))))))) + +(defun image-swap-bits-and-two-bytes + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (let ((byte-reverse *image-byte-reverse*)) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((length (index* (index-ceiling srclen 2) 2)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 2) + (if lsb-first-p + (setf (aref dest (index1+ (index+ deststart length))) + (br (aref src (index+ srcstart length)))) + (setf (aref dest (index+ deststart length)) + (br (aref src (index1+ (index+ srcstart length))))))) + (do ((i length (index- i 2)) + (srcidx srcstart (index+ srcidx 2)) + (destidx deststart (index+ destidx 2))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (br (aref src (index1+ srcidx)))) + (setf (aref dest (index1+ destidx)) + (br (aref src srcidx))))))))))) + +(defun image-swap-bits-and-four-bytes + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (let ((byte-reverse *image-byte-reverse*)) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((length (index* (index-ceiling srclen 4) 4)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length)) + (br (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 1)) + (br (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 2)) + (br (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 3)) + (br (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (br (aref src (index+ srcidx 3)))) + (setf (aref dest (index1+ destidx)) + (br (aref src (index+ srcidx 2)))) + (setf (aref dest (index+ destidx 2)) + (br (aref src (index1+ srcidx)))) + (setf (aref dest (index+ destidx 3)) + (br (aref src srcidx))))))))))) + +(defun image-swap-bits-and-words + (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type boolean lsb-first-p)) + #.(declare-buffun) + (with-vector (src buffer-bytes) + (with-vector (dest buffer-bytes) + (let ((byte-reverse *image-byte-reverse*)) + (with-vector (byte-reverse (simple-array card8 (256))) + (macrolet ((br (byte) + `(the card8 (aref byte-reverse (the card8 ,byte))))) + (do ((length (index* (index-ceiling srclen 4) 4)) + (h height (index1- h)) + (srcstart srcoff (index+ srcstart srcinc)) + (deststart destoff (index+ deststart destinc))) + ((index-zerop h)) + (declare (type array-index length srcstart deststart) + (type card16 h)) + (when (and (index= h 1) (not (index= srclen length))) + (index-decf length 4) + (unless lsb-first-p + (setf (aref dest (index+ deststart length 1)) + (br (aref src (index+ srcstart length 3))))) + (when (if lsb-first-p + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length)) + (br (aref src (index+ srcstart length 2))))) + (when (if (null lsb-first-p) + (index= (index- srclen length) 3) + (not (index-zerop (index-logand srclen 2)))) + (setf (aref dest (index+ deststart length 3)) + (br (aref src (index+ srcstart length 1))))) + (when lsb-first-p + (setf (aref dest (index+ deststart length 2)) + (br (aref src (index+ srcstart length)))))) + (do ((i length (index- i 4)) + (srcidx srcstart (index+ srcidx 4)) + (destidx deststart (index+ destidx 4))) + ((index-zerop i)) + (declare (type array-index i srcidx destidx)) + (setf (aref dest destidx) + (br (aref src (index+ srcidx 2)))) + (setf (aref dest (index1+ destidx)) + (br (aref src (index+ srcidx 3)))) + (setf (aref dest (index+ destidx 2)) + (br (aref src srcidx))) + (setf (aref dest (index+ destidx 3)) + (br (aref src (index1+ srcidx)))))))))))) + +;;; The following table gives the bit ordering within bytes (when accessed +;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to +;;; 31, where bit 0 should be leftmost on the display. For a given byte +;;; labelled A-B, A is for the most significant bit of the byte, and B is +;;; for the least significant bit. +;;; +;;; legend: +;;; 1 scanline-unit = 8 +;;; 2 scanline-unit = 16 +;;; 4 scanline-unit = 32 +;;; M byte-order = MostSignificant +;;; L byte-order = LeastSignificant +;;; m bit-order = MostSignificant +;;; l bit-order = LeastSignificant +;;; +;;; +;;; format ordering +;;; +;;; 1Mm 00-07 08-15 16-23 24-31 +;;; 2Mm 00-07 08-15 16-23 24-31 +;;; 4Mm 00-07 08-15 16-23 24-31 +;;; 1Ml 07-00 15-08 23-16 31-24 +;;; 2Ml 15-08 07-00 31-24 23-16 +;;; 4Ml 31-24 23-16 15-08 07-00 +;;; 1Lm 00-07 08-15 16-23 24-31 +;;; 2Lm 08-15 00-07 24-31 16-23 +;;; 4Lm 24-31 16-23 08-15 00-07 +;;; 1Ll 07-00 15-08 23-16 31-24 +;;; 2Ll 07-00 15-08 23-16 31-24 +;;; 4Ll 07-00 15-08 23-16 31-24 +;;; +;;; +;;; The following table gives the required conversion between any two +;;; formats. It is based strictly on the table above. If you believe one, +;;; you should believe the other. +;;; +;;; legend: +;;; n no changes +;;; s reverse 8-bit units within 16-bit units +;;; l reverse 8-bit units within 32-bit units +;;; w reverse 16-bit units within 32-bit units +;;; r reverse bits within 8-bit units +;;; sr s+R +;;; lr l+R +;;; wr w+R + +(defconstant + *image-swap-function* + '#.(make-array + '(12 12) :initial-contents + (let ((n 'image-noswap) + (s 'image-swap-two-bytes) + (l 'image-swap-four-bytes) + (w 'image-swap-words) + (r 'image-swap-bits) + (sr 'image-swap-bits-and-two-bytes) + (lr 'image-swap-bits-and-four-bytes) + (wr 'image-swap-bits-and-words)) + (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# + (list #| 1Mm |# n n n r sr lr n s l r r r ) + (list #| 2Mm |# n n n r sr lr n s l r r r ) + (list #| 4Mm |# n n n r sr lr n s l r r r ) + (list #| 1Ml |# r r r n s l r sr lr n n n ) + (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) + (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) + (list #| 1Lm |# n n n r sr lr n s l r r r ) + (list #| 2Lm |# s s s sr r wr s n w sr sr sr) + (list #| 4Lm |# l l l lr wr r l w n lr lr lr) + (list #| 1Ll |# r r r n s l r sr lr n n n ) + (list #| 2Ll |# r r r n s l r sr lr n n n ) + (list #| 4Ll |# r r r n s l r sr lr n n n ))))) + +;;; Of course, the table above is a lie. We also need to factor in the +;;; order of the source data to cope with swapping half of a unit at the +;;; end of a scanline, since we are trying to avoid de-ref'ing off the +;;; end of the source. +;;; +;;; Defines whether the first half of a unit has the first half of the data + +(defconstant + *image-swap-lsb-first-p* + '#.(make-array + 12 :initial-contents + (list t #| 1mm |# + t #| 2mm |# + t #| 4mm |# + t #| 1ml |# + nil #| 2ml |# + nil #| 4ml |# + t #| 1lm |# + nil #| 2lm |# + nil #| 4lm |# + t #| 1ll |# + t #| 2ll |# + t #| 4ll |# + ))) + +(defun image-swap-function + (from-bitmap-unit from-bitmap-byte-lsb-first-p + from-bitmap-bit-lsb-first-p to-bitmap-unit + to-bitmap-byte-lsb-first-p to-bitmap-bit-lsb-first-p) + (declare (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type boolean from-bitmap-bit-lsb-first-p + from-bitmap-byte-lsb-first-p to-bitmap-bit-lsb-first-p + to-bitmap-byte-lsb-first-p) + (values function lsb-first-p)) + (let ((from-index + (index+ + (ecase from-bitmap-unit (32 2) (16 1) (8 0)) + (if from-bitmap-bit-lsb-first-p 3 0) + (if from-bitmap-byte-lsb-first-p 6 0)))) + (values + (aref *image-swap-function* from-index + (index+ + (ecase to-bitmap-unit (32 2) (16 1) (8 0)) + (if to-bitmap-bit-lsb-first-p 3 0) + (if to-bitmap-byte-lsb-first-p 6 0))) + (aref *image-swap-lsb-first-p* from-index)))) + +(defun image-swap-xy + (src dest srcoff destoff srclen srcinc destinc height + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type card16 height) + (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p)) + (multiple-value-bind (function lsb-first-p) + (image-swap-function + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (declare (type symbol function) + (type boolean lsb-first-p)) + (funcall function src dest srcoff destoff srclen srcinc destinc height + lsb-first-p))) + +(defun image-swap-z + (src dest srcoff destoff srclen srcinc destinc height + bits-per-pixel from-byte-lsb-first-p to-byte-lsb-first-p) + (declare (type buffer-bytes src dest) + (type array-index srcoff destoff srclen srcinc destinc) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type card16 height) + (type boolean from-byte-lsb-first-p to-byte-lsb-first-p)) + (cond ((or (eq from-byte-lsb-first-p to-byte-lsb-first-p) + (= bits-per-pixel 8)) + (image-noswap + src dest srcoff destoff srclen srcinc destinc height + from-byte-lsb-first-p)) + ((= bits-per-pixel 32) + (image-swap-four-bytes + src dest srcoff destoff srclen srcinc destinc height + from-byte-lsb-first-p)) + ((= bits-per-pixel 24) + (image-swap-three-bytes + src dest srcoff destoff srclen srcinc destinc height + from-byte-lsb-first-p)) + ((= bits-per-pixel 16) + (image-swap-two-bytes + src dest srcoff destoff srclen srcinc destinc height + from-byte-lsb-first-p)) + (t + (image-swap-nibbles + src dest srcoff destoff srclen srcinc destinc height)))) + + +;;;----------------------------------------------------------------------------- +;;; GET-IMAGE + +(defun read-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 8)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-bits (index-mod (index- x) 8)) + (right-bits (index-mod (index- width left-bits) 8)) + (middle-bits (index- width left-bits right-bits)) + (middle-bytes (index-floor middle-bits 8))) + ((index>= y height)) + (declare (type array-index start y + left-bits right-bits middle-bits middle-bytes)) + (cond ((index< middle-bits 0) + (let ((byte (aref buffer-bbuf (index1- start))) + (x left-bits)) + (declare (type card8 byte) + (type array-index x)) + (when (index> right-bits 6) + (setf (aref array y (index- x 1)) + (read-image-load-byte 1 7 byte))) + (when (and (index> left-bits 1) + (index> right-bits 5)) + (setf (aref array y (index- x 2)) + (read-image-load-byte 1 6 byte))) + (when (and (index> left-bits 2) + (index> right-bits 4)) + (setf (aref array y (index- x 3)) + (read-image-load-byte 1 5 byte))) + (when (and (index> left-bits 3) + (index> right-bits 3)) + (setf (aref array y (index- x 4)) + (read-image-load-byte 1 4 byte))) + (when (and (index> left-bits 4) + (index> right-bits 2)) + (setf (aref array y (index- x 5)) + (read-image-load-byte 1 3 byte))) + (when (and (index> left-bits 5) + (index> right-bits 1)) + (setf (aref array y (index- x 6)) + (read-image-load-byte 1 2 byte))) + (when (index> left-bits 6) + (setf (aref array y (index- x 7)) + (read-image-load-byte 1 1 byte))))) + (t + (unless (index-zerop left-bits) + (let ((byte (aref buffer-bbuf (index1- start))) + (x left-bits)) + (declare (type card8 byte) + (type array-index x)) + (setf (aref array y (index- x 1)) + (read-image-load-byte 1 7 byte)) + (when (index> left-bits 1) + (setf (aref array y (index- x 2)) + (read-image-load-byte 1 6 byte)) + (when (index> left-bits 2) + (setf (aref array y (index- x 3)) + (read-image-load-byte 1 5 byte)) + (when (index> left-bits 3) + (setf (aref array y (index- x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> left-bits 4) + (setf (aref array y (index- x 5)) + (read-image-load-byte 1 3 byte)) + (when (index> left-bits 5) + (setf (aref array y (index- x 6)) + (read-image-load-byte 1 2 byte)) + (when (index> left-bits 6) + (setf (aref array y (index- x 7)) + (read-image-load-byte 1 1 byte)) + )))))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x left-bits (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((byte (aref buffer-bbuf end)) + (x (index+ left-bits middle-bits))) + (declare (type card8 byte) + (type array-index x)) + (setf (aref array y (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (when (index> right-bits 1) + (setf (aref array y (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (when (index> right-bits 2) + (setf (aref array y (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (when (index> right-bits 3) + (setf (aref array y (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (when (index> right-bits 4) + (setf (aref array y (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (when (index> right-bits 5) + (setf (aref array y (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (when (index> right-bits 6) + (setf (aref array y (index+ x 6)) + (read-image-load-byte 1 6 byte)) + ))))))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref array y (index+ x 0)) + (read-image-load-byte 1 0 byte)) + (setf (aref array y (index+ x 1)) + (read-image-load-byte 1 1 byte)) + (setf (aref array y (index+ x 2)) + (read-image-load-byte 1 2 byte)) + (setf (aref array y (index+ x 3)) + (read-image-load-byte 1 3 byte)) + (setf (aref array y (index+ x 4)) + (read-image-load-byte 1 4 byte)) + (setf (aref array y (index+ x 5)) + (read-image-load-byte 1 5 byte)) + (setf (aref array y (index+ x 6)) + (read-image-load-byte 1 6 byte)) + (setf (aref array y (index+ x 7)) + (read-image-load-byte 1 7 byte)))) + ))))) + +(defun read-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index-ceiling x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y)) + (left-nibbles (index-mod (index- x) 2)) + (right-nibbles (index-mod (index- width left-nibbles) 2)) + (middle-nibbles (index- width left-nibbles right-nibbles)) + (middle-bytes (index-floor middle-nibbles 2))) + ((index>= y height)) + (declare (type array-index start y + left-nibbles right-nibbles middle-nibbles middle-bytes)) + (unless (index-zerop left-nibbles) + (setf (aref array y 0) + (read-image-load-byte + 4 4 (aref buffer-bbuf (index1- start))))) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (x left-nibbles (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref array y (index+ left-nibbles middle-nibbles)) + (read-image-load-byte 4 0 (aref buffer-bbuf end))))) + (declare (type array-index end i x)) + (let ((byte (aref buffer-bbuf i))) + (declare (type card8 byte)) + (setf (aref array y (index+ x 0)) + (read-image-load-byte 4 0 byte)) + (setf (aref array y (index+ x 1)) + (read-image-load-byte 4 4 byte)))) + ))) + +(defun read-pixarray-8 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-8 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + x) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start width)) + (i start (index1+ i)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (the card8 (aref buffer-bbuf i))))))) + +(defun read-pixarray-16 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-16 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index* x 2)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start (index* width 2))) + (i start (index+ i 2)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)))))))) + +(defun read-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index* x 3)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)))))))) + +(defun read-pixarray-32 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-32 array) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((start (index+ index + (index* y padded-bytes-per-line) + (index* x 4)) + (index+ start padded-bytes-per-line)) + (y 0 (index1+ y))) + ((index>= y height)) + (declare (type array-index start y)) + (do* ((end (index+ start (index* width 4))) + (i start (index+ i 4)) + (x 0 (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref array y x) + (read-image-assemble-bytes + (aref buffer-bbuf (index+ i 0)) + (aref buffer-bbuf (index+ i 1)) + (aref buffer-bbuf (index+ i 2)) + (aref buffer-bbuf (index+ i 3)))))))) + +(defun read-xy-format-image-x + (buffer-bbuf index length data width height depth + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p pad) + (declare (type buffer-bytes buffer-bbuf) + (type card16 width height) + (type array-index index length padded-bytes-per-line + padded-bytes-per-plane) + (type image-depth depth) + (type (member 8 16 32) unit pad) + (type boolean byte-lsb-first-p bit-lsb-first-p) + (values image-x)) + (assert (index<= (index* depth padded-bytes-per-plane) length)) + (let* ((bytes-per-line (index-ceiling width 8)) + (data-length (index* padded-bytes-per-plane depth))) + (declare (type array-index bytes-per-line data-length)) + (cond (data + (check-type data buffer-bytes) + (assert (index>= (length data) data-length))) + (t + (setq data (make-array data-length :element-type 'card8)))) + (do ((plane 0 (index1+ plane))) + ((index>= plane depth)) + (declare (type image-depth plane)) + (image-noswap + buffer-bbuf data + (index+ index (index* plane padded-bytes-per-plane)) + (index* plane padded-bytes-per-plane) + bytes-per-line padded-bytes-per-line padded-bytes-per-line + height byte-lsb-first-p)) + (create-image + :width width :height height :depth depth :data data + :bits-per-pixel 1 :format :xy-pixmap + :bytes-per-line padded-bytes-per-line + :unit unit :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad))) + +(defun read-z-format-image-x + (buffer-bbuf index length data width height depth + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel) + (declare (type buffer-bytes buffer-bbuf) + (type card16 width height) + (type array-index index length padded-bytes-per-line) + (type image-depth depth) + (type (member 8 16 32) unit pad) + (type boolean byte-lsb-first-p bit-lsb-first-p) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (values image-x)) + (assert (index<= (index* height padded-bytes-per-line) length)) + (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8)) + (data-length (index* padded-bytes-per-line height))) + (declare (type array-index bytes-per-line data-length)) + (cond (data + (check-type data buffer-bytes) + (assert (index>= (length data) data-length))) + (t + (setq data (make-array data-length :element-type 'card8)))) + (image-noswap + buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line + padded-bytes-per-line height byte-lsb-first-p) + (create-image + :width width :height height :depth depth :data data + :bits-per-pixel bits-per-pixel :format :z-pixmap + :bytes-per-line padded-bytes-per-line + :unit unit :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad))) + +(defmacro with-image-data-buffer ((buffer size) &body body) + (declare (indentation 0 4 1 1)) + `(let ((.reply-buffer. (allocate-reply-buffer ,size))) + (declare (type reply-buffer .reply-buffer.)) + (unwind-protect + (let ((,buffer (reply-ibuf8 .reply-buffer.))) + (declare (type buffer-bytes ,buffer)) + (with-vector (,buffer buffer-bytes) + ,@body)) + (deallocate-reply-buffer .reply-buffer.)))) + +(defun read-image-xy-data (bbuf index pixarray x y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes bbuf) + (type array-index index padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (let* ((x1 (index* (index-floor x unit) unit)) + (x (index- x x1)) + (width1 (index+ width x)) + (padded-bits-per-line1 + (index* (index-ceiling width1 *image-pad*) *image-pad*)) + (padded-bytes-per-line1 (index-ceiling padded-bits-per-line1 8))) + (declare (type card16 x1 x width1) + (type array-index padded-bits-per-line1 padded-bytes-per-line1)) + (with-image-data-buffer (buf (index* height padded-bytes-per-line1)) + (image-swap-xy + bbuf buf + (index+ index + (index* y padded-bytes-per-line) + (index-floor x1 8)) + 0 + (index-ceiling width1 8) + padded-bytes-per-line padded-bytes-per-line1 + height + unit byte-lsb-first-p bit-lsb-first-p + *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*) + (unless (fast-read-pixarray + buf 0 pixarray x 0 width height padded-bytes-per-line1 1) + (read-pixarray-1 + buf 0 pixarray x 0 width height padded-bytes-per-line1))))) + +(defun read-image-xy (bbuf index length data x y width height depth + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes bbuf) + (type card16 x y width height) + (type array-index index length padded-bytes-per-line + padded-bytes-per-plane) + (type image-depth depth) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p) + (values image-xy)) + (check-type data list) + (multiple-value-bind (dimensions element-type) + (if data + (values (array-dimensions (first data)) + (array-element-type (first data))) + (values (list height + (index* (index-ceiling width *image-pad*) *image-pad*)) + 'pixarray-1-element-type)) + (do* ((arrays data) + (result nil) + (limit (index+ length index)) + (plane 0 (1+ plane)) + (index index (index+ index padded-bytes-per-plane))) + ((or (>= plane depth) + (index> (index+ index padded-bytes-per-plane) limit)) + (setq data (nreverse result) depth (length data))) + (declare (type array-index limit index) + (type image-depth plane) + (type list arrays result)) + (let ((array (or (pop arrays) + (make-array dimensions :element-type element-type)))) + (declare (type pixarray-1 array)) + (push array result) + (read-image-xy-data + bbuf index array x y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p))) + (create-image + :width width :height height :depth depth :data data))) + +(defun read-image-z-data (bbuf index pixarray x y width height + padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes bbuf) + (type array-index index padded-bytes-per-line) + (type pixarray pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (if (index= bits-per-pixel 1) + (read-image-xy-data + bbuf index pixarray x y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (let* ((xbits (index* x bits-per-pixel)) + (xbits1 (index* (index-floor xbits unit) unit)) + (x1 (index-floor xbits1 bits-per-pixel)) + (x (index- x x1)) + (width1 (index+ width x)) + (bits-per-line1 (index* width1 bits-per-pixel)) + (bytes-per-line1 (index-ceiling bits-per-line1 8)) + (padded-bits-per-line1 + (index* (index-ceiling bits-per-line1 *image-pad*) *image-pad*)) + (padded-bytes-per-line1 + (index-ceiling padded-bits-per-line1 8))) + (declare (type array-index xbits xbits1 x1 x + bits-per-line1 bytes-per-line1 + padded-bits-per-line1 padded-bytes-per-line1)) + (with-image-data-buffer (buf (index* height padded-bytes-per-line1)) + (image-swap-z + bbuf buf + (index+ index + (index* y padded-bytes-per-line) + (index-floor xbits1 8)) + 0 + bytes-per-line1 + padded-bytes-per-line padded-bytes-per-line1 + height + bits-per-pixel byte-lsb-first-p *image-byte-lsb-first-p*) + (unless (fast-read-pixarray + buf 0 pixarray x 0 width height padded-bytes-per-line1 + bits-per-pixel) + (funcall + (ecase bits-per-pixel + (1 #'read-pixarray-1) (4 #'read-pixarray-4) + (8 #'read-pixarray-8) (16 #'read-pixarray-16) + (24 #'read-pixarray-24) (32 #'read-pixarray-32)) + buf 0 pixarray x 0 width height padded-bytes-per-line1)))))) + +(defun read-image-z (bbuf index length data x y width height depth + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes bbuf) + (type card16 x y width height) + (type array-index index length padded-bytes-per-line) + (type image-depth depth) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p) + (values image-z)) + (assert (index<= (index* (index+ y height) padded-bytes-per-line) length)) + (let* ((image-bits-per-line (index* width bits-per-pixel)) + (image-pixels-per-line + (index-ceiling + (index* (index-ceiling image-bits-per-line *image-pad*) + *image-pad*) + bits-per-pixel))) + (declare (type array-index image-bits-per-line image-pixels-per-line)) + (unless data + (setq data + (make-array + (list height image-pixels-per-line) + :element-type (ecase bits-per-pixel + (1 'pixarray-1-element-type) + (4 'pixarray-4-element-type) + (8 'pixarray-8-element-type) + (16 'pixarray-16-element-type) + (24 'pixarray-24-element-type) + (32 'pixarray-32-element-type))))) + (read-image-z-data + bbuf index data x y width height + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (create-image + :width width :height height :depth depth :data data + :bits-per-pixel bits-per-pixel))) + +(defun get-image (drawable &key + data + (x (required-arg x)) + (y (required-arg y)) + (width (required-arg width)) + (height (required-arg height)) + plane-mask format result-type) + (declare (type drawable drawable) + (type (or buffer-bytes list pixarray) data) + (type int16 x y) ;; required + (type card16 width height) ;; required + (type (or null pixel) plane-mask) + (type (or null (member :xy-pixmap :z-pixmap)) format) + (type (or null (member image-xy image-x image-z)) result-type) + (values image visual-info)) + (unless result-type + (setq result-type (ecase format + (:xy-pixmap 'image-xy) + (:z-pixmap 'image-z) + ((nil) 'image-x)))) + (unless format + (setq format (case result-type + (image-xy :xy-pixmap) + ((image-z image-x) :z-pixmap)))) + (unless (ecase result-type + (image-xy (eq format :xy-pixmap)) + (image-z (eq format :z-pixmap)) + (image-x t)) + (error "Result-type ~s is incompatable with format ~s" + result-type format)) + (unless plane-mask (setq plane-mask #xffffffff)) + (let ((display (drawable-display drawable))) + (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32)) + (((data (member error :xy-pixmap :z-pixmap)) format) + (drawable drawable) + (int16 x y) + (card16 width height) + (card32 plane-mask)) + (let* ((depth (card8-get 1)) + (length (index* 4 (card32-get 4))) + (visual-info (visual-info display (resource-id-get 8))) + (bitmap-format (display-bitmap-format display)) + (unit (bitmap-format-unit bitmap-format)) + (byte-lsb-first-p (display-image-lsb-first-p display)) + (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) + (declare (type image-depth depth) + (type array-index length) + (type (or null visual-info) visual-info) + (type bitmap-format bitmap-format) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (multiple-value-bind (pad bits-per-pixel) + (ecase format + (:xy-pixmap + (values (bitmap-format-pad bitmap-format) 1)) + (:z-pixmap + (if (= depth 1) + (values (bitmap-format-pad bitmap-format) 1) + (let ((pixmap-format + (find depth (display-pixmap-formats display) + :key #'pixmap-format-depth))) + (declare (type pixmap-format pixmap-format)) + (values (pixmap-format-scanline-pad pixmap-format) + (pixmap-format-bits-per-pixel pixmap-format)))))) + (declare (type (member 8 16 32) pad) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (let* ((bits-per-line (index* bits-per-pixel width)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line pad) pad)) + (padded-bytes-per-line + (index-ceiling padded-bits-per-line 8)) + (padded-bytes-per-plane + (index* padded-bytes-per-line height)) + (image + (ecase result-type + (image-x + (ecase format + (:xy-pixmap + (read-xy-format-image-x + buffer-bbuf *replysize* length data + width height depth + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p + pad)) + (:z-pixmap + (read-z-format-image-x + buffer-bbuf *replysize* length data + width height depth + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p + pad bits-per-pixel)))) + (image-xy + (read-image-xy + buffer-bbuf *replysize* length data + 0 0 width height depth + padded-bytes-per-line padded-bytes-per-plane + unit byte-lsb-first-p bit-lsb-first-p)) + (image-z + (read-image-z + buffer-bbuf *replysize* length data + 0 0 width height depth padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p))))) + (declare (type image image) + (type array-index bits-per-line + padded-bits-per-line padded-bytes-per-line)) + (when visual-info + (unless (zerop (visual-info-red-mask visual-info)) + (setf (image-red-mask image) + (visual-info-red-mask visual-info))) + (unless (zerop (visual-info-green-mask visual-info)) + (setf (image-green-mask image) + (visual-info-green-mask visual-info))) + (unless (zerop (visual-info-blue-mask visual-info)) + (setf (image-blue-mask image) + (visual-info-blue-mask visual-info)))) + (values image visual-info))))))) + + +;;;----------------------------------------------------------------------------- +;;; PUT-IMAGE + +(defun write-pixarray-1 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-1 array) + (type card16 x y width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (right-bits (index-mod width 8)) + (middle-bits (index- width right-bits)) + (middle-bytes (index-ceiling middle-bits 8)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-bits middle-bits + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x start-x (index+ x 8))) + ((index>= i end) + (unless (index-zerop right-bits) + (let ((x (index+ start-x middle-bits))) + (declare (type array-index x)) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ x 0)) + (if (index> right-bits 1) + (aref array y (index+ x 1)) + 0) + (if (index> right-bits 2) + (aref array y (index+ x 2)) + 0) + (if (index> right-bits 3) + (aref array y (index+ x 3)) + 0) + (if (index> right-bits 4) + (aref array y (index+ x 4)) + 0) + (if (index> right-bits 5) + (aref array y (index+ x 5)) + 0) + (if (index> right-bits 6) + (aref array y (index+ x 6)) + 0) + 0))))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref array y (index+ x 0)) + (aref array y (index+ x 1)) + (aref array y (index+ x 2)) + (aref array y (index+ x 3)) + (aref array y (index+ x 4)) + (aref array y (index+ x 5)) + (aref array y (index+ x 6)) + (aref array y (index+ x 7)))))))) + +(defun write-pixarray-4 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-4 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (right-nibbles (index-mod width 2)) + (middle-nibbles (index- width right-nibbles)) + (middle-bytes (index-ceiling middle-nibbles 2)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y right-nibbles middle-nibbles + middle-bytes start)) + (do* ((end (index+ start middle-bytes)) + (i start (index1+ i)) + (start-x x) + (x start-x (index+ x 2))) + ((index>= i end) + (unless (index-zerop right-nibbles) + (setf (aref buffer-bbuf end) + (write-image-assemble-bytes + (aref array y (index+ start-x middle-nibbles)) + 0)))) + (declare (type array-index end i start-x x)) + (setf (aref buffer-bbuf i) + (write-image-assemble-bytes + (aref array y (index+ x 0)) + (aref array y (index+ x 1)))))))) + +(defun write-pixarray-8 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-8 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y start)) + (do* ((end (index+ start width)) + (i start (index1+ i)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (setf (aref buffer-bbuf i) (the card8 (aref array y x))))))) + +(defun write-pixarray-16 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-16 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y start)) + (do* ((end (index+ start (index* width 2))) + (i start (index+ i 2)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref array y x))) + (declare (type pixarray-16-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 16)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 16))))))) + +(defun write-pixarray-24 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-24 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index y start)) + (do* ((end (index+ start (index* width 3))) + (i start (index+ i 3)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref array y x))) + (declare (type pixarray-24-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 24)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 24)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 24))))))) + +(defun write-pixarray-32 (buffer-bbuf index array x y width height + padded-bytes-per-line) + (declare (type buffer-bytes buffer-bbuf) + (type pixarray-32 array) + (type int16 x y) + (type card16 width height) + (type array-index index padded-bytes-per-line)) + #.(declare-buffun) + (with-vector (buffer-bbuf buffer-bytes) + (do* ((h 0 (index1+ h)) + (y y (index1+ y)) + (start index (index+ start padded-bytes-per-line))) + ((index>= h height)) + (declare (type array-index h y start)) + (do* ((end (index+ start (index* width 4))) + (i start (index+ i 4)) + (x x (index1+ x))) + ((index>= i end)) + (declare (type array-index end i x)) + (let ((pixel (aref array y x))) + (declare (type pixarray-32-element-type pixel)) + (setf (aref buffer-bbuf (index+ i 0)) + (write-image-load-byte 0 pixel 32)) + (setf (aref buffer-bbuf (index+ i 1)) + (write-image-load-byte 8 pixel 32)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 16 pixel 32)) + (setf (aref buffer-bbuf (index+ i 2)) + (write-image-load-byte 24 pixel 32))))))) + +(defun write-xy-format-image-x-data + (data obuf data-start obuf-start x y width height + from-padded-bytes-per-line to-padded-bytes-per-line + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (declare (type buffer-bytes data obuf) + (type array-index data-start obuf-start + from-padded-bytes-per-line to-padded-bytes-per-line) + (type card16 x y width height) + (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p)) + (assert (index-zerop (index-mod x 8))) + (let ((x-mod-unit (index-mod x from-bitmap-unit))) + (declare (type card16 x-mod-unit)) + (if (and (index-plusp x-mod-unit) + (not (eq from-byte-lsb-first-p from-bit-lsb-first-p))) + (let* ((temp-width (index+ width x-mod-unit)) + (temp-bytes-per-line (index-ceiling temp-width 8)) + (temp-padded-bits-per-line + (index* (index-ceiling temp-width from-bitmap-unit) + from-bitmap-unit)) + (temp-padded-bytes-per-line + (index-ceiling temp-padded-bits-per-line 8))) + (declare (type card16 temp-width temp-bytes-per-line + temp-padded-bits-per-line temp-padded-bytes-per-line)) + (with-image-data-buffer (buf (index* height + temp-padded-bytes-per-line)) + (image-swap-xy + data buf + (index+ data-start + (index* y from-padded-bytes-per-line) + (index-floor (index- x x-mod-unit) 8)) + 0 + temp-bytes-per-line + from-padded-bytes-per-line temp-padded-bytes-per-line + height + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p) + (write-xy-format-image-x-data + buf obuf 0 obuf-start x-mod-unit 0 width height + temp-padded-bytes-per-line to-padded-bytes-per-line + from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))) + (image-swap-xy + data obuf + (index+ data-start + (index* y from-padded-bytes-per-line) + (index-floor x 8)) + obuf-start + (index-ceiling width 8) + from-padded-bytes-per-line to-padded-bytes-per-line + height + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)))) + +(defun write-xy-format-image-x + (display image src-x src-y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type display display) + (type image-x image) + (type int16 src-x src-y) + (type card16 width height) + (type array-index padded-bytes-per-line) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (dotimes (plane (image-depth image)) + (let ((data-start + (index* (index* plane (image-height image)) + (image-x-bytes-per-line image))) + (src-y src-y) + (height height)) + (declare (type int16 src-y) + (type card16 height)) + (loop + (when (index-zerop height) (return)) + (let ((nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) + (declare (type array-index nlines)) + (when (index-plusp nlines) + (write-xy-format-image-x-data + (image-x-data image) (buffer-obuf8 display) + data-start (buffer-boffset display) + src-x src-y width nlines + (image-x-bytes-per-line image) padded-bytes-per-line + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image) + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) + (buffer-flush display))))) + +(defun write-z-format-image-x-data + (data obuf data-start obuf-start x y width height + from-padded-bytes-per-line to-padded-bytes-per-line + bits-per-pixel + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (declare (type buffer-bytes data obuf) + (type array-index data-start obuf-start + from-padded-bytes-per-line to-padded-bytes-per-line) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) + (type boolean from-byte-lsb-first-p from-bit-lsb-first-p + to-byte-lsb-first-p to-bit-lsb-first-p)) + (if (index= bits-per-pixel 1) + (write-xy-format-image-x-data + data obuf data-start obuf-start x y width height + from-padded-bytes-per-line to-padded-bytes-per-line + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) + (let ((srcoff + (index+ data-start + (index* y from-padded-bytes-per-line) + (index-floor (index* x bits-per-pixel) 8))) + (srclen (index-ceiling (index* width bits-per-pixel) 8))) + (declare (type array-index srcoff srclen)) + (if (and (index= bits-per-pixel 4) (index-oddp x)) + (with-image-data-buffer (buf (index* height to-padded-bytes-per-line)) + (image-swap-nibbles-left + data buf srcoff 0 srclen + from-padded-bytes-per-line to-padded-bytes-per-line height) + (write-z-format-image-x-data + buf obuf 0 obuf-start 0 0 width height + to-padded-bytes-per-line to-padded-bytes-per-line + bits-per-pixel + from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p + to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)) + (image-swap-z + data obuf srcoff obuf-start srclen + from-padded-bytes-per-line to-padded-bytes-per-line height + bits-per-pixel from-byte-lsb-first-p to-byte-lsb-first-p))))) + +(defun write-z-format-image-x (display image src-x src-y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type display display) + (type image-x image) + (type int16 src-x src-y) + (type card16 width height) + (type array-index padded-bytes-per-line) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (loop + (when (index-zerop height) (return)) + (let ((nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) + (declare (type array-index nlines)) + (when (index-plusp nlines) + (write-z-format-image-x-data + (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display) + src-x src-y width nlines + (image-x-bytes-per-line image) padded-bytes-per-line + (image-x-bits-per-pixel image) + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image) + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) + (buffer-flush display))) + +(defun write-image-xy-data (obuf boffset pixarray x y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes obuf) + (type array-index boffset padded-bytes-per-line) + (type pixarray-1 pixarray) + (type card16 x y width height) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (with-image-data-buffer (buf (index* height padded-bytes-per-line)) + (unless (fast-write-pixarray + buf 0 pixarray x y width height padded-bytes-per-line 1) + (write-pixarray-1 + buf 0 pixarray x y width height padded-bytes-per-line)) + (image-swap-xy + buf obuf 0 boffset (index-ceiling width 8) + padded-bytes-per-line padded-bytes-per-line height + *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p* + unit byte-lsb-first-p bit-lsb-first-p))) + +(defun write-image-xy (display image src-x src-y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type display display) + (type image-xy image) + (type array-index padded-bytes-per-line) + (type int16 src-x src-y) + (type card16 width height) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (dolist (bitmap (image-xy-bitmap-list image)) + (declare (type pixarray-1 bitmap)) + (let ((src-y src-y) + (height height)) + (declare (type int16 src-y) + (type card16 height)) + (loop + (let ((nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) + (declare (type array-index nlines)) + (when (index-plusp nlines) + (write-image-xy-data + (buffer-obuf8 display) (buffer-boffset display) + bitmap src-x src-y width nlines + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) + (buffer-flush display))))) + +(defun write-image-z-data (obuf boffset pixarray x y width height + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type buffer-bytes obuf) + (type array-index boffset padded-bytes-per-line) + (type pixarray-1 pixarray) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (if (index= bits-per-pixel 1) + (write-image-xy-data + obuf boffset pixarray x y width height padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (with-image-data-buffer (buf (index* height padded-bytes-per-line)) + (unless (fast-write-pixarray + buf 0 pixarray x y width height + padded-bytes-per-line bits-per-pixel) + (funcall + (ecase bits-per-pixel + (1 #'write-pixarray-1) (4 #'write-pixarray-4) + (8 #'write-pixarray-8) (16 #'write-pixarray-16) + (24 #'write-pixarray-24) (32 #'write-pixarray-32)) + buf 0 pixarray x y width height padded-bytes-per-line)) + (image-swap-z + buf obuf 0 boffset + (index-ceiling (index* width bits-per-pixel) 8) + padded-bytes-per-line padded-bytes-per-line + height bits-per-pixel + *image-byte-lsb-first-p* byte-lsb-first-p)))) + +(defun write-image-z (display image src-x src-y width height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p) + (declare (type display display) + (type image-z image) + (type array-index padded-bytes-per-line) + (type int16 src-x src-y) + (type card16 width height) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (loop + (let ((bits-per-pixel (image-z-bits-per-pixel image)) + (nlines + (index-min (index-floor (index- (buffer-size display) + (buffer-boffset display)) + padded-bytes-per-line) + height))) + (declare (type (member 1 4 8 16 24 32) bits-per-pixel) + (type array-index nlines)) + (when (index-plusp nlines) + (write-image-z-data + (buffer-obuf8 display) (buffer-boffset display) + (image-z-pixarray image) src-x src-y width nlines + padded-bytes-per-line bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p) + (index-incf (buffer-boffset display) + (index* nlines padded-bytes-per-line)) + (index-incf src-y nlines) + (when (index-zerop (index-decf height nlines)) (return)))) + (buffer-flush display))) + +;;; Note: The only difference between a format of :bitmap and :xy-pixmap +;;; of depth 1 is that when sending a :bitmap format the foreground +;;; and background in the gcontext are used. + +(defun put-image (drawable gcontext image &key + (src-x 0) (src-y 0) ;Position within image + (x (required-arg x)) ;Position within drawable + (y (required-arg y)) + width height + bitmap-p) + ;; Copy an image into a drawable. + ;; WIDTH and HEIGHT default from IMAGE. + ;; When BITMAP-P, force format to be :bitmap when depth=1. + ;; This causes gcontext to supply foreground & background pixels. + (declare (type drawable drawable) + (type gcontext gcontext) + (type image image) + (type int16 x y) ;; required + (type int16 src-x src-y) + (type (or null card16) width height) + (type boolean bitmap-p)) + (let* ((format + (etypecase image + (image-x (image-x-format (the image-x image))) + (image-xy :xy-pixmap) + (image-z :z-pixmap))) + (src-x + (if (image-x-p image) + (index+ src-x (image-x-left-pad (the image-x image))) + src-x)) + (image-width (image-width image)) + (image-height (image-height image)) + (width (min (or width image-width) (index- image-width src-x))) + (height (min (or height image-height) (index- image-height src-y))) + (depth (image-depth image)) + (display (drawable-display drawable)) + (bitmap-format (display-bitmap-format display)) + (unit (bitmap-format-unit bitmap-format)) + (byte-lsb-first-p (display-image-lsb-first-p display)) + (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) + (declare (type (member :bitmap :xy-pixmap :z-pixmap) format) + (type card16 src-x image-width image-height width height) + (type image-depth depth) + (type display display) + (type bitmap-format bitmap-format) + (type (member 8 16 32) unit) + (type boolean byte-lsb-first-p bit-lsb-first-p)) + (when (and bitmap-p (not (index= depth 1))) + (error "Bitmaps must have depth 1")) + (unless (index<= 0 src-x (index1- (image-width image))) + (error "src-x not inside image")) + (unless (index<= 0 src-y (index1- (image-height image))) + (error "src-y not inside image")) + (when (and (index> width 0) (index> height 0)) + (multiple-value-bind (pad bits-per-pixel) + (ecase format + ((:bitmap :xy-pixmap) + (values (bitmap-format-pad bitmap-format) 1)) + (:z-pixmap + (if (= depth 1) + (values (bitmap-format-pad bitmap-format) 1) + (let ((pixmap-format + (find depth (display-pixmap-formats display) + :key #'pixmap-format-depth))) + (declare (type pixmap-format pixmap-format)) + (values (pixmap-format-scanline-pad pixmap-format) + (pixmap-format-bits-per-pixel pixmap-format)))))) + (declare (type (member 8 16 32) pad) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (let* ((left-pad + (if (or (eq format :xy-pixmap) (= depth 1)) + (index-mod src-x (index-min pad *image-pad*)) + 0)) + (left-padded-src-x (index- src-x left-pad)) + (left-padded-width (index+ width left-pad)) + (bits-per-line (index* left-padded-width bits-per-pixel)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line pad) pad)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (request-bytes-per-line + (ecase format + ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth)) + (:z-pixmap padded-bytes-per-line))) + (max-bytes-per-request + (index* (index- (display-max-request-length display) 6) 4)) + (max-request-height + (floor max-bytes-per-request request-bytes-per-line))) + (declare (type card8 left-pad) + (type int16 left-padded-src-x) + (type card16 left-padded-width) + (type array-index bits-per-line padded-bits-per-line + padded-bytes-per-line request-bytes-per-line + max-bytes-per-request max-request-height)) + ;; Be sure that a scanline can fit in a request + (when (index-zerop max-request-height) + (error "Can't even fit one image scanline in a request")) + ;; Be sure a scanline can fit in a buffer + (buffer-ensure-size display padded-bytes-per-line) + ;; Send the image in multiple requests to avoid exceeding the + ;; request limit + (do* ((request-src-y src-y (index+ request-src-y request-height)) + (request-y y (index+ request-y request-height)) + (height-remaining + height (index- height-remaining request-height)) + (request-height + (index-min height-remaining max-request-height) + (index-min height-remaining max-request-height))) + ((index<= height-remaining 0)) + (declare (type array-index request-src-y height-remaining + request-height)) + (let* ((request-bytes (index* request-bytes-per-line request-height)) + (request-words (index-ceiling request-bytes 4)) + (request-length (index+ request-words 6))) + (declare (type array-index request-bytes) + (type card16 request-words request-length)) + (with-buffer-request (display *x-putimage* :gc-force gcontext) + ((data (member :bitmap :xy-pixmap :z-pixmap)) + (cond ((or (eq format :bitmap) bitmap-p) :bitmap) + ((plusp left-pad) :xy-pixmap) + (t format))) + (drawable drawable) + (gcontext gcontext) + (card16 width request-height) + (int16 x request-y) + (card8 left-pad depth) + (pad16 nil) + (progn + (length-put 2 request-length) + (setf (buffer-boffset display) (advance-buffer-offset 24)) + (etypecase image + (image-x + (ecase (image-x-format (the image-x image)) + ((:bitmap :xy-pixmap) + (write-xy-format-image-x + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p)) + (:z-pixmap + (write-z-format-image-x + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p)))) + (image-xy + (write-image-xy + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p)) + (image-z + (write-image-z + display image left-padded-src-x request-src-y + left-padded-width request-height + padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p))) + ;; Be sure the request is padded to a multiple of 4 bytes + (buffer-pad-request display (index- (index* request-words 4) request-bytes)) + ))))))))) + +;;;----------------------------------------------------------------------------- +;;; COPY-IMAGE + +(defun xy-format-image-x->image-x (image x y width height) + (declare (type image-x image) + (type card16 x y width height) + (values image-x)) + (let* ((padded-x (index+ x (image-x-left-pad image))) + (left-pad (index-mod padded-x 8)) + (x (index- padded-x left-pad)) + (unit (image-x-unit image)) + (byte-lsb-first-p (image-x-byte-lsb-first-p image)) + (bit-lsb-first-p (image-x-bit-lsb-first-p image)) + (pad (image-x-pad image)) + (padded-width + (index* (index-ceiling (index+ width left-pad) pad) pad)) + (padded-bytes-per-line (index-ceiling padded-width 8)) + (padded-bytes-per-plane (index* padded-bytes-per-line height)) + (length (index* padded-bytes-per-plane (image-depth image))) + (obuf (make-array length :element-type 'card8))) + (declare (type card16 x) + (type card8 left-pad) + (type (member 8 16 32) unit pad) + (type array-index padded-width padded-bytes-per-line + padded-bytes-per-plane length) + (type buffer-bytes obuf)) + (dotimes (plane (image-depth image)) + (let ((data-start + (index* (image-x-bytes-per-line image) + (image-height image) + plane)) + (obuf-start + (index* padded-bytes-per-plane + plane))) + (declare (type array-index data-start obuf-start)) + (write-xy-format-image-x-data + (image-x-data image) obuf data-start obuf-start + x y width height + (image-x-bytes-per-line image) padded-bytes-per-line + unit byte-lsb-first-p bit-lsb-first-p + unit byte-lsb-first-p bit-lsb-first-p))) + (create-image + :width width :height height :depth (image-depth image) + :data obuf :format (image-x-format image) :bits-per-pixel 1 + :bytes-per-line padded-bytes-per-line + :unit unit :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p :pad pad :left-pad left-pad))) + +(defun z-format-image-x->image-x (image x y width height) + (declare (type image-x image) + (type card16 x y width height) + (values image-x)) + (let* ((padded-x (index+ x (image-x-left-pad image))) + (left-pad + (if (index= (image-depth image) 1) + (index-mod padded-x 8) + 0)) + (x (index- padded-x left-pad)) + (bits-per-pixel (image-x-bits-per-pixel image)) + (unit (image-x-unit image)) + (byte-lsb-first-p (image-x-byte-lsb-first-p image)) + (bit-lsb-first-p (image-x-bit-lsb-first-p image)) + (pad (image-x-pad image)) + (bits-per-line (index* (index+ width left-pad) bits-per-pixel)) + (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (padded-bytes-per-plane (index* padded-bytes-per-line height)) + (length (index* padded-bytes-per-plane (image-depth image))) + (obuf (make-array length :element-type 'card8))) + (declare (type card16 x) + (type card8 left-pad) + (type (member 8 16 32) unit pad) + (type array-index bits-per-pixel padded-bytes-per-line + padded-bytes-per-plane length) + (type buffer-bytes obuf)) + (write-z-format-image-x-data + (image-x-data image) obuf 0 0 + x y width height + (image-x-bytes-per-line image) padded-bytes-per-line + bits-per-pixel + unit byte-lsb-first-p bit-lsb-first-p + unit byte-lsb-first-p bit-lsb-first-p) + (create-image + :width width :height height :depth (image-depth image) + :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel + :bytes-per-line padded-bytes-per-line + :unit unit :byte-lsb-first-p byte-lsb-first-p + :bit-lsb-first-p bit-lsb-first-p :pad pad :left-pad left-pad))) + +(defun image-x->image-x (image x y width height) + (declare (type image-x image) + (type card16 x y width height) + (values image-x)) + (ecase (image-x-format image) + ((:bitmap :xy-pixmap) + (xy-format-image-x->image-x image x y width height)) + (:z-pixmap + (z-format-image-x->image-x image x y width height)))) + +(defun image-x->image-xy (image x y width height) + (declare (type image-x image) + (type card16 x y width height) + (values image-xy)) + (unless (or (eq (image-x-format image) :bitmap) + (eq (image-x-format image) :xy-pixmap) + (and (eq (image-x-format image) :z-pixmap) + (index= (image-depth image) 1))) + (error "Format conversion from ~S to ~S not supported" + (image-x-format image) :xy-pixmap)) + (read-image-xy + (image-x-data image) 0 (length (image-x-data image)) nil + (index+ x (image-x-left-pad image)) y width height + (image-depth image) (image-x-bytes-per-line image) + (index* (image-x-bytes-per-line image) (image-height image)) + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image))) + +(defun image-x->image-z (image x y width height) + (declare (type image-x image) + (type card16 x y width height) + (values image-z)) + (unless (or (eq (image-x-format image) :z-pixmap) + (eq (image-x-format image) :bitmap) + (and (eq (image-x-format image) :xy-pixmap) + (index= (image-depth image) 1))) + (error "Format conversion from ~S to ~S not supported" + (image-x-format image) :z-pixmap)) + (read-image-z + (image-x-data image) 0 (length (image-x-data image)) nil + (index+ x (image-x-left-pad image)) y width height + (image-depth image) (image-x-bytes-per-line image) + (image-x-bits-per-pixel image) + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image))) + +(defun copy-pixarray (array x y width height bits-per-pixel) + (declare (type pixarray array) + (type card16 x y width height) + (type (member 1 4 8 16 24 32) bits-per-pixel)) + (let* ((bits-per-line (index* bits-per-pixel width)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line *image-pad*) *image-pad*)) + (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) + (copy (make-array (list height padded-width) + :element-type (array-element-type array)))) + (declare (type array-index bits-per-line padded-bits-per-line padded-width) + (type pixarray copy)) + #.(declare-buffun) + (unless (fast-copy-pixarray array copy x y width height bits-per-pixel) + (macrolet + ((copy (array-type element-type) + `(let ((array array) + (copy copy)) + (declare (type ,array-type array copy)) + (do* ((dst-y 0 (index1+ dst-y)) + (src-y y (index1+ src-y))) + ((index>= dst-y height)) + (declare (type card16 dst-y src-y)) + (do* ((dst-x 0 (index1+ dst-x)) + (src-x x (index1+ src-x))) + ((index>= dst-x width)) + (declare (type card16 dst-x src-x)) + (setf (aref copy dst-y dst-x) + (the ,element-type + (aref array src-y src-x)))))))) + (ecase bits-per-pixel + (1 (copy pixarray-1 pixarray-1-element-type)) + (4 (copy pixarray-4 pixarray-4-element-type)) + (8 (copy pixarray-8 pixarray-8-element-type)) + (16 (copy pixarray-16 pixarray-16-element-type)) + (24 (copy pixarray-24 pixarray-24-element-type)) + (32 (copy pixarray-32 pixarray-32-element-type))))) + copy)) + +(defun image-xy->image-x (image x y width height) + (declare (type image-xy image) + (type card16 x y width height) + (values image-x)) + (let* ((padded-bits-per-line + (index* (index-ceiling width *image-pad*) *image-pad*)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (padded-bytes-per-plane (index* padded-bytes-per-line height)) + (bytes-total (index* padded-bytes-per-plane (image-depth image))) + (data (make-array bytes-total :element-type 'card8))) + (declare (type array-index padded-bits-per-line padded-bytes-per-line + padded-bytes-per-plane bytes-total) + (type buffer-bytes data)) + (let ((index 0)) + (declare (type array-index index)) + (dolist (bitmap (image-xy-bitmap-list image)) + (declare (type pixarray-1 bitmap)) + (unless (fast-write-pixarray + data index bitmap x y width height + padded-bytes-per-line 1) + (write-pixarray-1 + data index bitmap x y width height + padded-bytes-per-line)) + (index-incf index padded-bytes-per-plane))) + (create-image + :width width :height height :depth (image-depth image) + :data data :format :xy-pixmap :bits-per-pixel 1 + :bytes-per-line padded-bytes-per-line + :unit *image-unit* :byte-lsb-first-p *image-byte-lsb-first-p* + :bit-lsb-first-p *image-bit-lsb-first-p* :pad *image-pad*))) + +(defun image-xy->image-xy (image x y width height) + (declare (type image-xy image) + (type card16 x y width height) + (values image-xy)) + (create-image + :width width :height height :depth (image-depth image) + :data (mapcar + #'(lambda (array) + (declare (type pixarray-1 array)) + (copy-pixarray array x y width height 1)) + (image-xy-bitmap-list image)))) + +(defun image-xy->image-z (image x y width height) + (declare (type image-z image) + (type card16 x y width height) + (ignore image x y width height)) + (error "Format conversion from ~S to ~S not supported" + :xy-pixmap :z-pixmap)) + +(defun image-z->image-x (image x y width height) + (declare (type image-z image) + (type card16 x y width height) + (values image-x)) + (let* ((bits-per-line (index* width (image-z-bits-per-pixel image))) + (padded-bits-per-line + (index* (index-ceiling bits-per-line *image-pad*) *image-pad*)) + (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) + (bytes-total + (index* padded-bytes-per-line height (image-depth image))) + (data (make-array bytes-total :element-type 'card8))) + (declare (type array-index bits-per-line padded-bits-per-line + padded-bytes-per-line bytes-total) + (type buffer-bytes data)) + (unless (fast-write-pixarray + data 0 (image-z-pixarray image) x y width height + padded-bytes-per-line + (image-z-bits-per-pixel image)) + (funcall + (ecase (image-z-bits-per-pixel image) + (1 #'write-pixarray-1) (4 #'write-pixarray-4) + (8 #'write-pixarray-8) (16 #'write-pixarray-16) + (24 #'write-pixarray-24) (32 #'write-pixarray-32)) + data 0 (image-z-pixarray image) x y width height + padded-bytes-per-line)) + (create-image + :width width :height height :depth (image-depth image) + :data data :format :z-pixmap + :bits-per-pixel (image-z-bits-per-pixel image) + :bytes-per-line padded-bytes-per-line + :unit *image-unit* :byte-lsb-first-p *image-byte-lsb-first-p* + :bit-lsb-first-p *image-bit-lsb-first-p* :pad *image-pad*))) + +(defun image-z->image-xy (image x y width height) + (declare (type image-z image) + (type card16 x y width height) + (ignore image x y width height)) + (error "Format conversion from ~S to ~S not supported" + :z-pixmap :xy-pixmap)) + +(defun image-z->image-z (image x y width height) + (declare (type image-z image) + (type card16 x y width height) + (values image-z)) + (create-image + :width width :height height :depth (image-depth image) + :data (copy-pixarray + (image-z-pixarray image) x y width height + (image-z-bits-per-pixel image)))) + +(defun copy-image (image &key (x 0) (y 0) width height result-type) + ;; Copy with optional sub-imaging and format conversion. + ;; result-type defaults to (type-of image) + (declare (type image image) + (type card16 x y) + (type (or null card16) width height) ;; Default from image + (type (or null (member image-x image-xy image-z)) result-type)) + (declare (values image)) + (let* ((image-width (image-width image)) + (image-height (image-height image)) + (width (or width image-width)) + (height (or height image-height))) + (declare (type card16 image-width image-height width height)) + (unless (index<= 0 x (index1- image-width)) (error "x not inside image")) + (unless (index<= 0 y (index1- image-height)) (error "y not inside image")) + (setq width (index-min width (index-max (index- image-width x) 0))) + (setq height (index-min height (index-max (index- image-height y) 0))) + (let ((copy + (etypecase image + (image-x + (ecase result-type + ((nil image-x) (image-x->image-x image x y width height)) + (image-xy (image-x->image-xy image x y width height)) + (image-z (image-x->image-z image x y width height)))) + (image-xy + (ecase result-type + (image-x (image-xy->image-x image x y width height)) + ((nil image-xy) (image-xy->image-xy image x y width height)) + (image-z (image-xy->image-z image x y width height)))) + (image-z + (ecase result-type + (image-x (image-z->image-x image x y width height)) + (image-xy (image-z->image-xy image x y width height)) + ((nil image-z) (image-z->image-z image x y width height))))))) + (declare (type image copy)) + (setf (image-plist copy) (copy-list (image-plist image))) + (when (and (image-x-hot image) (not (index-zerop x))) + (setf (image-x-hot copy) (index- (image-x-hot image) x))) + (when (and (image-y-hot image) (not (index-zerop y))) + (setf (image-y-hot copy) (index- (image-y-hot image) y))) + copy))) + + +;;;----------------------------------------------------------------------------- +;;; Image I/O functions + + +(defun read-bitmap-file (pathname) + ;; Creates an image from a C include file in standard X11 format + (declare (type (or pathname string stream) pathname)) + (declare (values image)) + (with-open-file (fstream pathname :direction :input) + (let ((line "") + (properties nil) + (name nil) + (name-end nil) + (*package* (find-package 'keyword)) + (*read-base* 10)) + (declare (type string line) + (type stringable name) + (type list properties)) + ;; Get properties + (loop + (setq line (read-line fstream)) + (unless (char= (aref line 0) #\#) (return)) + (flet ((read-keyword (line start end) + (kintern + (substitute + #\- #\_ + (#-excl string-upcase + #+excl correct-case + (subseq line start end)) + :test #'char=)))) + (when (null name) + (setq name-end (position #\_ line :test #'char= :from-end t) + name (read-keyword line 8 name-end)) + (unless (eq name :image) + (setf (getf properties :name) name))) + (let* ((ind-start (index1+ name-end)) + (ind-end (position #\Space line :test #'char= + :start ind-start)) + (ind (read-keyword line ind-start ind-end)) + (val-start (index1+ ind-end)) + (val (parse-integer line :start val-start))) + (setf (getf properties ind) val)))) + ;; Calculate sizes + (multiple-value-bind (width height depth left-pad) + (flet ((extract-property (ind &rest default) + (prog1 (apply #'getf properties ind default) + (remf properties ind)))) + (values (extract-property :width) + (extract-property :height) + (extract-property :depth 1) + (extract-property :left-pad 0))) + (declare (type (or null card16) width height) + (type image-depth depth) + (type card8 left-pad)) + (unless (and width height) (error "Not a BITMAP file")) + (let* ((bits-per-pixel + (cond ((index> depth 24) 32) + ((index> depth 16) 24) + ((index> depth 8) 16) + ((index> depth 4) 8) + ((index> depth 1) 4) + (t 1))) + (bits-per-line (index* width bits-per-pixel)) + (bytes-per-line (index-ceiling bits-per-line 8)) + (padded-bits-per-line + (index* (index-ceiling bits-per-line 32) 32)) + (padded-bytes-per-line + (index-ceiling padded-bits-per-line 8)) + (data (make-array (* padded-bytes-per-line height) + :element-type 'card8)) + (line-base 0) + (byte 0)) + (declare (type array-index bits-per-line bytes-per-line + padded-bits-per-line padded-bytes-per-line + line-base byte) + (type buffer-bytes data)) + (with-vector (data buffer-bytes) + (flet ((parse-hex (char) + (second + (assoc char + '((#\0 0) (#\1 1) (#\2 2) (#\3 3) + (#\4 4) (#\5 5) (#\6 6) (#\7 7) + (#\8 8) (#\9 6) (#\a 10) (#\b 11) + (#\c 12) (#\d 13) (#\e 14) (#\f 15)) + :test #'char-equal)))) + ;; Read data + ;; Note: using read-line instead of read-char would be 20% faster, + ;; but would cons a lot of garbage... + (dotimes (i height) + (dotimes (j bytes-per-line) + (loop (when (eql (read-char fstream) #\x) (return))) + (setf (aref data (index+ line-base byte)) + (index+ (index-ash (parse-hex (read-char fstream)) 4) + (parse-hex (read-char fstream)))) + (incf byte)) + (setq byte 0 + line-base (index+ line-base padded-bytes-per-line))))) + ;; Compensate for left-pad in width and x-hot + (index-decf width left-pad) + (when (getf properties :x-hot) + (index-decf (getf properties :x-hot) left-pad)) + (create-image + :width width :height height + :depth depth :bits-per-pixel bits-per-pixel + :data data :plist properties :format :z-pixmap + :bytes-per-line padded-bytes-per-line + :unit 32 :byte-lsb-first-p t :bit-lsb-first-p t + :pad 32 :left-pad left-pad)))))) + +(defun write-bitmap-file (pathname image &optional name) + ;; Writes an image to a C include file in standard X11 format + ;; NAME argument used for variable prefixes. Defaults to "image" + (declare (type (or pathname string stream) pathname) + (type image image) + (type (or null stringable) name)) + (unless (typep image 'image-x) + (setq image (copy-image image :result-type 'image-x))) + (let* ((plist (image-plist image)) + (name (or name (image-name image) 'image)) + (left-pad (image-x-left-pad image)) + (width (index+ (image-width image) left-pad)) + (height (image-height image)) + (depth + (if (eq (image-x-format image) :z-pixmap) + (image-depth image) + 1)) + (bits-per-pixel (image-x-bits-per-pixel image)) + (bits-per-line (index* width bits-per-pixel)) + (bytes-per-line (index-ceiling bits-per-line 8)) + (last (index* bytes-per-line height)) + (count 0)) + (declare (type list plist) + (type stringable name) + (type card8 left-pad) + (type card16 width height) + (type (member 1 4 8 16 24 32) bits-per-pixel) + (type image-depth depth) + (type array-index bits-per-line bytes-per-line count last)) + ;; Move x-hot by left-pad, if there is an x-hot, so image readers that + ;; don't know about left pad get the hot spot in the right place. We have + ;; already increased width by left-pad. + (when (getf plist :x-hot) + (setq plist (copy-list plist)) + (index-incf (getf plist :x-hot) left-pad)) + (with-image-data-buffer (data last) + (if (index> bits-per-pixel 1) + (image-swap-z + (image-x-data image) data 0 0 bytes-per-line + (image-x-bytes-per-line image) bytes-per-line + height bits-per-pixel + (image-x-byte-lsb-first-p image) t) + (image-swap-xy + (image-x-data image) data 0 0 bytes-per-line + (image-x-bytes-per-line image) bytes-per-line + height + (image-x-unit image) (image-x-byte-lsb-first-p image) + (image-x-bit-lsb-first-p image) + 32 t t)) + (with-vector (data buffer-bytes) + (setq name (string-downcase (string name))) + (with-open-file (fstream pathname :direction :output) + (format fstream "#define ~a_width ~d~%" name width) + (format fstream "#define ~a_height ~d~%" name height) + (unless (= depth 1) + (format fstream "#define ~a_depth ~d~%" name depth)) + (unless (zerop left-pad) + (format fstream "#define ~a_left_pad ~d~%" name left-pad)) + (do ((prop plist (cddr prop))) + ((endp prop)) + (when (and (not (member (car prop) '(:width :height))) + (numberp (cadr prop))) + (format fstream "#define ~a_~a ~d~%" + name + (substitute + #\_ #\- (string-downcase (string (car prop))) + :test #'char=) + (cadr prop)))) + (format fstream "static char ~a_bits[] = {" name) + (dotimes (i height) + (dotimes (j bytes-per-line) + (when (zerop (index-mod count 15)) + (terpri fstream) + (write-char #\space fstream)) + (write-string "0x" fstream) + ;; Faster than (format fstream "0x~2,'0x," byte) + (let ((byte (aref data count)) + (translate "0123456789abcdef")) + (declare (type card8 byte)) + (write-char (char translate (ldb (byte 4 4) byte)) fstream) + (write-char (char translate (ldb (byte 4 0) byte)) fstream)) + (index-incf count) + (unless (index= count last) + (write-char #\, fstream)))) + (format fstream "};~%" fstream)))))) + +(defun bitmap-image (&optional plist &rest patterns) + ;; Create an image containg pattern + ;; PATTERNS are bit-vector constants (e.g. #*10101) + ;; If the first parameter is a list, its used as the image property-list. + (declare (type (or list bit-vector) plist) + (type list patterns)) ;; list of bitvector + (declare (values image)) + (unless (listp plist) + (push plist patterns) + (setq plist nil)) + (let* ((width (length (first patterns))) + (height (length patterns)) + (bitarray (make-array (list height width) :element-type 'bit)) + (row 0)) + (declare (type card16 width height row) + (type pixarray-1 bitarray)) + (dolist (pattern patterns) + (declare (type simple-bit-vector pattern)) + (dotimes (col width) + (declare (type card16 col)) + (setf (aref bitarray row col) (the bit (aref pattern col)))) + (incf row)) + (create-image :width width :height height :plist plist :data bitarray))) + +(defun image-pixmap (drawable image &key gcontext width height depth) + ;; Create a pixmap containing IMAGE. Size defaults from the image. + ;; DEPTH is the pixmap depth. + ;; GCONTEXT is used for putting the image into the pixmap. + ;; If none is supplied, then one is created, used then freed. + (declare (type drawable drawable) + (type image image) + (type (or null gcontext) gcontext) + (type (or null card16) width height) + (type (or null card8) depth)) + (declare (values pixmap)) + (let* ((image-width (image-width image)) + (image-height (image-height image)) + (image-depth (image-depth image)) + (width (or width image-width)) + (height (or height image-height)) + (depth (or depth image-depth)) + (pixmap (create-pixmap :drawable drawable + :width width + :height height + :depth depth)) + (gc (or gcontext (create-gcontext + :drawable pixmap + :foreground 1 + :background 0)))) + (unless (= depth image-depth) + (if (= image-depth 1) + (unless gcontext (xlib::required-arg gcontext)) + (error "Pixmap depth ~d incompatable with image depth ~d" + depth image-depth))) + (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) gcontext)) + ;; Tile when image-width is less than the pixmap width, or + ;; the image-height is less than the pixmap height. + ;; ??? Would it be better to create a temporary pixmap and + ;; ??? let the server do the tileing? + (do ((x image-width (+ x image-width))) + ((>= x width)) + (copy-area pixmap gc 0 0 image-width image-height pixmap x 0) + (incf image-width image-width)) + (do ((y image-height (+ y image-height))) + ((>= y height)) + (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y) + (incf image-height image-height)) + (unless gcontext (free-gcontext gc)) + pixmap)) + diff --git a/clx/input.lisp b/clx/input.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b2ed082209f4d18e969935d1e8d4b2cfa66a20e9 --- /dev/null +++ b/clx/input.lisp @@ -0,0 +1,1927 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +;;; +;;; Change history: +;;; +;;; Date Author Description +;;; ------------------------------------------------------------------------------------- +;;; 12/10/87 LGO Created + +(in-package :xlib) + +(export '( + event-listen + queue-event + process-event + make-event-handlers + event-handler + event-case + event-cond + discard-current-event + request-error + value-error + window-error + pixmap-error + atom-error + cursor-error + font-error + match-error + drawable-error + access-error + alloc-error + colormap-error + gcontext-error + id-choice-error + name-error + length-error + implementation-error + request-error + resource-error + unknown-error + access-error + alloc-error + atom-error + colormap-error + cursor-error + drawable-error + font-error + gcontext-error + id-choice-error + illegal-request-error + length-error + match-error + name-error + pixmap-error + value-error + window-error + implementation-error + #-ansi-common-lisp type-error + closed-display + lookup-error + connection-failure + reply-length-error + reply-timeout + sequence-error + unexpected-reply + missing-parameter + invalid-font + device-busy + get-external-event-code + define-extension + extension-opcode + define-error + decode-core-error + declare-event + )) + +;; Event Resource +(defvar *event-free-list* nil) ;; List of unused (processed) events + +(eval-when (eval compile load) +(defconstant *max-events* 64) ;; Maximum number of events supported (the X11 alpha release only has 34) +(defvar *event-key-vector* (make-array *max-events* :initial-element nil) + "Vector of event keys - See define-event") +) +(defvar *event-macro-vector* (make-array *max-events* :initial-element nil) + "Vector of event handler functions - See declare-event") +(defvar *event-handler-vector* (make-array *max-events* :initial-element nil) + "Vector of event handler functions - See declare-event") +(defvar *event-send-vector* (make-array *max-events* :initial-element nil) + "Vector of event sending functions - See declare-event") + +(defun allocate-event () + (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer) + (make-reply-buffer *replysize*))) + +(defun deallocate-event (reply-buffer) + (declare (type reply-buffer reply-buffer)) + (setf (reply-size reply-buffer) *replysize*) + (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer)) + +;; Extensions are handled as follows: +;; DEFINITION: Use DEFINE-EXTENSION +;; +;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension. +;; This looks up the code on the display-extension-alist. +;; +;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE +;; at LOAD time to define an internal event-code number +;; (stored in the 'event-code property of the event-name) +;; used to index the following vectors: +;; *event-key-vector* Used for getting the event-key +;; *event-macro-vector* Used for getting the event-parameter getting macros +;; +;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert +;; a server event-code into an internal event-code used to index the following +;; vectors: +;; *event-handler-vector* Used for getting the event-handler function +;; *event-send-vector* Used for getting the event-sending function +;; +;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert +;; internal event-codes to external (server) codes. +;; +;; ERRORS: Use DEFINE-ERROR to define new error decodings. +;; + + +;; Any event-code greater than 34 is for an extension +(defparameter *first-extension-event-code* 35) + +(defvar *extensions* nil) ;; alist of (extension-name-symbol events errors) + +(defmacro define-extension (name &key events errors) + ;; Define extension NAME with EVENTS and ERRORS. + ;; Note: The case of NAME is important. + ;; To define the request, Use: + ;; (with-buffer-request (display (extension-opcode ,name)) ,@body) + ;; See the REQUESTS file for lots of examples. + ;; To define event handlers, use declare-event. + ;; To define error handlers, use declare-error and define-condition. + (declare (type stringable name) + (type list events errors)) + (let ((name-symbol (kintern name)) ;; Intern name in the keyword package + (event-list (mapcar #'canonicalize-event-name events))) + `(eval-when (compile load eval) + (setq *extensions* (cons (list ',name-symbol ',event-list ',errors) + (delete ',name-symbol *extensions* :key #'car)))))) + +(eval-when (compile eval load) +(defun canonicalize-event-name (event) + ;; Returns the event name keyword given an event name stringable + (declare (type stringable event)) + (declare (values event-key)) + (kintern event)) +) ;; end eval-when + +(eval-when (compile eval load) +(defun allocate-extension-event-code (name) + ;; Allocate an event-code for an extension + ;; This is executed at COMPILE and LOAD time from DECLARE-EVENT. + ;; The event-code is used at compile-time by macros to index the following vectors: + ;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector* + (let ((event-code (get name 'event-code))) + (declare (type (or null card8) event-code)) + (unless event-code + ;; First ensure the name is for a declared extension + (unless (dolist (extension *extensions*) + (when (member name (second extension)) + (return t))) + (x-type-error name 'event-key)) + (setq event-code (position nil *event-key-vector* + :start *first-extension-event-code*)) + (setf (svref *event-key-vector* event-code) name) + (setf (get name 'event-code) event-code)) + event-code)) +) ;; end eval-when + +(defun get-internal-event-code (display code) + ;; Given an X11 event-code, return the internal event-code. + ;; The internal event-code is used for indexing into the following vectors: + ;; *event-key-vector* *event-handler-vector* *event-send-vector* + ;; Returns NIL when the event-code is for an extension that isn't handled. + (declare (type display display) + (type card8 code)) + (declare (values (or nil card8))) + (setq code (logand #x7f code)) + (if (< code *first-extension-event-code*) + code + (let* ((code-offset (- code *first-extension-event-code*)) + (event-extensions (display-event-extensions display)) + (code (if (< code-offset (length event-extensions)) + (aref event-extensions code-offset) + 0))) + (declare (type card8 code-offset code)) + (when (zerop code) + (x-cerror "Ignore the event" + 'unimplemented-event :event-code code :display display)) + code))) + +(defun get-external-event-code (display event) + ;; Given an X11 event name, return the event-code + (declare (type display display) + (type event-key event)) + (declare (values card8)) + (let ((code (get-event-code event))) + (declare (type (or null card8) code)) + (when (>= code *first-extension-event-code*) + (setq code (+ *first-extension-event-code* + (or (position code (display-event-extensions display)) + (x-error 'undefined-event :display display :event-name event))))) + code)) + +(defmacro extension-opcode (display name) + ;; Returns the major opcode for extension NAME. + ;; This is a macro to enable NAME to be interned for fast run-time + ;; retrieval. + ;; Note: The case of NAME is important. + (declare (type display display) + (type stringable name)) + (declare (values card8)) + (let ((name-symbol (kintern name))) ;; Intern name in the keyword package + `(or (second (assoc ',name-symbol (display-extension-alist ,display))) + (x-error 'absent-extension :name ',name-symbol :display ,display)))) + +(defun initialize-extensions (display) + ;; Initialize extensions for DISPLAY + (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0)) + (extension-alist nil)) + (declare (type vector event-extensions) + (type list extension-alist)) + (dolist (extension *extensions*) + (let ((name (first extension)) + (events (second extension))) + (declare (type keyword name) + (type list events)) + (multiple-value-bind (major-opcode first-event first-error) + (query-extension display name) + (declare (type (or null card8) major-opcode first-event first-error)) + (when (and major-opcode (plusp major-opcode)) + (push (list name major-opcode first-event first-error) + extension-alist) + (when (plusp first-event) ;; When there are extension events + ;; Grow extension vector when needed + (let ((max-event (- (+ first-event (length events)) + *first-extension-event-code*))) + (declare (type card8 max-event)) + (when (>= max-event (length event-extensions)) + (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8 + :initial-element 0))) + (declare (type vector new-extensions)) + (replace new-extensions event-extensions) + (setq event-extensions new-extensions)))) + (dolist (event events) + (declare (type symbol event)) + (setf (aref event-extensions (- first-event *first-extension-event-code*)) + (get-event-code event)) + (incf first-event))))))) + (setf (display-event-extensions display) event-extensions) + (setf (display-extension-alist display) extension-alist))) + +;; +;; Reply handlers +;; + +(defvar *pending-command-free-list* nil) + +(defun start-pending-command (display) + (declare (type display display)) + (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list* + pending-command-next pending-command) + (make-pending-command)))) + (declare (type pending-command pending-command)) + (setf (pending-command-reply-buffer pending-command) nil) + (setf (pending-command-process pending-command) (current-process)) + (setf (pending-command-sequence pending-command) + (ldb (byte 16 0) (1+ (buffer-request-number display)))) + ;; Add the pending command to the end of the threaded list of pending + ;; commands for the display. + (with-event-queue-internal (display) + (threaded-nconc pending-command (display-pending-commands display) + pending-command-next pending-command)) + pending-command)) + +(defun stop-pending-command (display pending-command) + (declare (type display display) + (type pending-command pending-command)) + (with-event-queue-internal (display) + ;; Remove the pending command from the threaded list of pending commands + ;; for the display. + (threaded-delete pending-command (display-pending-commands display) + pending-command-next pending-command) + ;; Deallocate any reply buffers in this pending command + (loop + (let ((reply-buffer + (threaded-pop (pending-command-reply-buffer pending-command) + reply-next reply-buffer))) + (declare (type (or null reply-buffer) reply-buffer)) + (if reply-buffer + (deallocate-reply-buffer reply-buffer) + (return nil))))) + ;; Deallocate this pending-command + (threaded-atomic-push pending-command *pending-command-free-list* + pending-command-next pending-command) + nil) + +;;; + +(defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil)) + +(defun allocate-reply-buffer (size) + (declare (type array-index size)) + (if (index<= size *replysize*) + (allocate-event) + (let ((index (integer-length (index1- size)))) + (declare (type array-index index)) + (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index) + reply-next reply-buffer) + (make-reply-buffer (index-ash 1 index)))))) + +(defun deallocate-reply-buffer (reply-buffer) + (declare (type reply-buffer reply-buffer)) + (let ((size (reply-size reply-buffer))) + (declare (type array-index size)) + (if (index<= size *replysize*) + (deallocate-event reply-buffer) + (let ((index (integer-length (index1- size)))) + (declare (type array-index index)) + (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index) + reply-next reply-buffer))))) + +;;; + +(defun read-error-input (display sequence reply-buffer token) + (declare (type display display) + (type reply-buffer reply-buffer) + (type card16 sequence)) + (tagbody + start + (with-event-queue-internal (display) + (let ((command + ;; Find any pending command with this sequence number. + (threaded-dolist (pending-command (display-pending-commands display) + pending-command-next pending-command) + (when (= (pending-command-sequence pending-command) sequence) + (return pending-command))))) + (declare (type (or null pending-command) command)) + (cond ((not (null command)) + ;; Give this reply to the pending command + (threaded-nconc reply-buffer (pending-command-reply-buffer command) + reply-next reply-buffer) + (process-wakeup (pending-command-process command))) + ((member :immediately (display-report-asynchronous-errors display)) + ;; No pending command and we should report the error immediately + (go report-error)) + (t + ;; No pending command found, count this as an asynchronous error + (threaded-nconc reply-buffer (display-asynchronous-errors display) + reply-next reply-buffer))))) + (return-from read-error-input nil) + report-error + (note-input-complete display token) + (apply #'report-error display + (prog1 (make-error display reply-buffer t) + (deallocate-event reply-buffer))))) + +(defun read-reply-input (display sequence length reply-buffer) + (declare (type display display) + (type (or null reply-buffer) reply-buffer) + (type card16 sequence) + (type array-index length)) + (unwind-protect + (progn + (when (index< *replysize* length) + (let ((repbuf nil)) + (declare (type (or null reply-buffer) repbuf)) + (unwind-protect + (progn + (setq repbuf (allocate-reply-buffer length)) + (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer) + 0 *replysize*) + (deallocate-event (shiftf reply-buffer repbuf nil))) + (when repbuf + (deallocate-reply-buffer repbuf)))) + (when (buffer-input display (reply-ibuf8 reply-buffer) *replysize* length) + (return-from read-reply-input t)) + (setf (reply-data-size reply-buffer) length)) + (with-event-queue-internal (display) + ;; Find any pending command with this sequence number. + (let ((command + (threaded-dolist (pending-command (display-pending-commands display) + pending-command-next pending-command) + (when (= (pending-command-sequence pending-command) sequence) + (return pending-command))))) + (declare (type (or null pending-command) command)) + (when command + ;; Give this reply to the pending command + (threaded-nconc (shiftf reply-buffer nil) + (pending-command-reply-buffer command) + reply-next reply-buffer) + (process-wakeup (pending-command-process command))))) + nil) + (when reply-buffer + (deallocate-reply-buffer reply-buffer)))) + +(defun read-event-input (display code reply-buffer) + (declare (type display display) + (type card8 code) + (type reply-buffer reply-buffer)) + ;; Push the event in the input buffer on the display's event queue + (setf (event-code reply-buffer) + (get-internal-event-code display code)) + (enqueue-event reply-buffer display) + nil) + +(defun note-input-complete (display token) + (declare (type display display)) + (when (eq (display-input-in-progress display) token) + ;; Indicate that input is no longer in progress + (setf (display-input-in-progress display) nil) + ;; Let the event process get the first chance to do input + (let ((process (display-event-process display))) + (when (not (null process)) + (process-wakeup process))) + ;; Then give processes waiting for command responses a chance + (unless (display-input-in-progress display) + (with-event-queue-internal (display) + (threaded-dolist (command (display-pending-commands display) + pending-command-next pending-command) + (process-wakeup (pending-command-process command))))))) + +(defun read-input (display timeout force-output-p predicate &rest predicate-args) + (declare (type display display) + (type (or null number) timeout) + (type boolean force-output-p) + (dynamic-extent predicate-args)) + (declare (type function predicate) + (downward-funarg predicate)) + (let ((reply-buffer nil) + (token (or (current-process) (cons nil nil)))) + (declare (type (or null reply-buffer) reply-buffer)) + (unwind-protect + (tagbody + loop + (when (display-dead display) + (x-error 'closed-display :display display)) + (when (apply predicate predicate-args) + (return-from read-input nil)) + ;; Check and see if we have to force output + (when (and force-output-p + (or (and (not (eq (display-input-in-progress display) token)) + (not (conditional-store + (display-input-in-progress display) nil token))) + (null (buffer-listen display)))) + (go force-output)) + ;; Ensure that ony one process is reading input. + (unless (or (eq (display-input-in-progress display) token) + (conditional-store (display-input-in-progress display) nil token)) + (if (eql timeout 0) + (return-from read-input :timeout) + (apply #'process-block "CLX Input Lock" + #'(lambda (display predicate &rest predicate-args) + (declare (type display display) + (dynamic-extent predicate-args) + (type function predicate) + (downward-funarg predicate)) + (or (apply predicate predicate-args) + (null (display-input-in-progress display)) + (not (null (display-dead display))))) + display predicate predicate-args)) + (go loop)) + ;; Now start gobbling. + (setq reply-buffer (allocate-event)) + (with-buffer-input (reply-buffer :sizes (8 16 32)) + (let ((type 0)) + (declare (type card8 type)) + ;; Wait for input before we disallow aborts. + (unless (eql timeout 0) + (let ((eof-p (buffer-input-wait display timeout))) + (when eof-p (return-from read-input eof-p)))) + (without-aborts + (let ((eof-p (buffer-input display buffer-bbuf 0 *replysize* + (if force-output-p 0 timeout)))) + (when eof-p + (when (eq eof-p :timeout) + (if force-output-p + (go force-output) + (return-from read-input :timeout))) + (setf (display-dead display) t) + (return-from read-input eof-p))) + (setf (reply-data-size reply-buffer) *replysize*) + (when (= (the card8 (setq type (read-card8 0))) 1) + ;; Normal replies can be longer than *replysize*, so we + ;; have to handle them while aborts are still disallowed. + (let ((value + (read-reply-input + display (read-card16 2) + (index+ *replysize* (index* (read-card32 4) 4)) + (shiftf reply-buffer nil)))) + (when value + (return-from read-input value)) + (go loop)))) + (if (zerop type) + (read-error-input + display (read-card16 2) (shiftf reply-buffer nil) token) + (read-event-input + display (read-card8 0) (shiftf reply-buffer nil))))) + (go loop) + force-output + (note-input-complete display token) + (display-force-output display) + (setq force-output-p nil) + (go loop)) + (when (not (null reply-buffer)) + (deallocate-reply-buffer reply-buffer)) + (note-input-complete display token)))) + +(defun report-asynchronous-errors (display mode) + (when (and (display-asynchronous-errors display) + (member mode (display-report-asynchronous-errors display))) + (let ((aborted t)) + (unwind-protect + (loop + (let ((error + (with-event-queue-internal (display) + (threaded-pop (display-asynchronous-errors display) + reply-next reply-buffer)))) + (declare (type (or null reply-buffer) error)) + (if error + (apply #'report-error display + (prog1 (make-error display error t) + (deallocate-event error))) + (return (setq aborted nil))))) + ;; If we get aborted out of this, deallocate all outstanding asynchronous + ;; errors. + (when aborted + (with-event-queue-internal (display) + (loop + (let ((reply-buffer + (threaded-pop (display-asynchronous-errors display) + reply-next reply-buffer))) + (declare (type (or null reply-buffer) reply-buffer)) + (if reply-buffer + (deallocate-event reply-buffer) + (return nil)))))))))) + +(defun wait-for-event (display timeout force-output-p) + (declare (type display display) + (type (or null number) timeout) + (type boolean force-output-p)) + (let ((event-process-p (not (eql timeout 0)))) + (declare (type boolean event-process-p)) + (unwind-protect + (loop + (when event-process-p + (conditional-store (display-event-process display) nil (current-process))) + (let ((eof (read-input + display timeout force-output-p + #'(lambda (display) + (declare (type display display)) + (or (not (null (display-new-events display))) + (and (display-asynchronous-errors display) + (member :before-event-handling + (display-report-asynchronous-errors display)) + t))) + display))) + (when eof (return eof))) + ;; Report asynchronous errors here if the user wants us to. + (when event-process-p + (report-asynchronous-errors display :before-event-handling)) + (when (not (null (display-new-events display))) + (return nil))) + (when (and event-process-p + (eq (display-event-process display) (current-process))) + (setf (display-event-process display) nil))))) + +(defun read-reply (display pending-command) + (declare (type display display) + (type pending-command pending-command)) + (loop + (when (read-input display nil nil + #'(lambda (pending-command) + (declare (type pending-command pending-command)) + (not (null (pending-command-reply-buffer pending-command)))) + pending-command) + (x-error 'closed-display :display display)) + (let ((reply-buffer + (with-event-queue-internal (display) + (threaded-pop (pending-command-reply-buffer pending-command) + reply-next reply-buffer)))) + (declare (type reply-buffer reply-buffer)) + ;; Check for error. + (with-buffer-input (reply-buffer) + (ecase (read-card8 0) + (0 (apply #'report-error display + (prog1 (make-error display reply-buffer nil) + (deallocate-reply-buffer reply-buffer)))) + (1 (return reply-buffer))))))) + +;;; + +(defun event-listen (display &optional (timeout 0)) + (declare (type display display) + (type (or null number) timeout) + (values number-of-events-queued eof-or-timeout)) + ;; Returns the number of events queued locally, if any, else nil. Hangs + ;; waiting for events, forever if timeout is nil, else for the specified + ;; number of seconds. + (let* ((current-event-symbol (car (display-current-event-symbol display))) + (current-event (and (boundp current-event-symbol) + (symbol-value current-event-symbol))) + (queue (or current-event (display-event-queue-head display)))) + (declare (type symbol current-event-symbol) + (type (or null reply-buffer) current-event queue)) + (if queue + (values + (with-event-queue-internal (display :timeout timeout) + (threaded-length (or current-event (display-event-queue-head display)) + reply-next reply-buffer)) + nil) + (with-event-queue (display :timeout timeout :inline t) + (let ((eof-or-timeout (wait-for-event display timeout nil))) + (if eof-or-timeout + (values nil eof-or-timeout) + (values + (with-event-queue-internal (display :timeout timeout) + (threaded-length (display-event-queue-head display) + reply-next reply-buffer)) + nil))))))) + +(defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys) + ;; The event is put at the head of the queue if append-p is nil, else the tail. + ;; Additional arguments depend on event-key, and are as specified above with + ;; declare-event, except that both resource-ids and resource objects are accepted + ;; in the event components. + (declare (type display display) + (type event-key event-key) + (type boolean append-p send-event-p) + (dynamic-extent args)) + (unless (get event-key 'event-code) + (x-type-error event-key 'event-key)) + (let* ((event (allocate-event)) + (buffer (reply-ibuf8 event)) + (event-code (get event-key 'event-code))) + (declare (type reply-buffer event) + (type buffer-bytes buffer) + (type (or null card8) event-code)) + (unless event-code (x-type-error event-key 'event-key)) + (setf (event-code event) event-code) + (with-display (display) + (apply (svref *event-send-vector* event-code) display args) + (buffer-replace buffer + (display-obuf8 display) + 0 + *replysize* + (index+ 12 (buffer-boffset display))) + (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code) + (aref buffer 2) 0 + (aref buffer 3) 0)) + (with-event-queue (display) + (if append-p + (enqueue-event event display) + (with-event-queue-internal (display) + (threaded-requeue event + (display-event-queue-head display) + (display-event-queue-tail display) + reply-next reply-buffer)))))) + +(defun enqueue-event (new-event display) + (declare (type reply-buffer new-event) + (type display display)) + ;; Place EVENT at the end of the event queue for DISPLAY + (let* ((event-code (event-code new-event)) + (event-key (and (index< event-code (length *event-key-vector*)) + (svref *event-key-vector* event-code)))) + (declare (type array-index event-code) + (type (or null keyword) event-key)) + (if (null event-key) + (unwind-protect + (cerror "Ignore this event" "No handler for ~s event" event-key) + (deallocate-event new-event)) + (with-event-queue-internal (display) + (threaded-enqueue new-event + (display-event-queue-head display) + (display-event-queue-tail display) + reply-next reply-buffer) + (unless (display-new-events display) + (setf (display-new-events display) new-event)))))) + + +(defmacro define-event (name code) + `(eval-when (eval compile load) + (setf (svref *event-key-vector* ,code) ',name) + (setf (get ',name 'event-code) ,code))) + +;; Event names. Used in "type" field in XEvent structures. Not to be +;; confused with event masks above. They start from 2 because 0 and 1 +;; are reserved in the protocol for errors and replies. */ + +(define-event :key-press 2) +(define-event :key-release 3) +(define-event :button-press 4) +(define-event :button-release 5) +(define-event :motion-notify 6) +(define-event :enter-notify 7) +(define-event :leave-notify 8) +(define-event :focus-in 9) +(define-event :focus-out 10) +(define-event :keymap-notify 11) +(define-event :exposure 12) +(define-event :graphics-exposure 13) +(define-event :no-exposure 14) +(define-event :visibility-notify 15) +(define-event :create-notify 16) +(define-event :destroy-notify 17) +(define-event :unmap-notify 18) +(define-event :map-notify 19) +(define-event :map-request 20) +(define-event :reparent-notify 21) +(define-event :configure-notify 22) +(define-event :configure-request 23) +(define-event :gravity-notify 24) +(define-event :resize-request 25) +(define-event :circulate-notify 26) +(define-event :circulate-request 27) +(define-event :property-notify 28) +(define-event :selection-clear 29) +(define-event :selection-request 30) +(define-event :selection-notify 31) +(define-event :colormap-notify 32) +(define-event :client-message 33) +(define-event :mapping-notify 34) + + +(defmacro declare-event (event-codes &body declares) + ;; Used to indicate the keyword arguments for handler functions in + ;; process-event and event-case. + ;; Generates the functions used in SEND-EVENT. + ;; A compiler warning is printed when all of EVENT-CODES are not + ;; defined by a preceding DEFINE-EXTENSION. + ;; The body is a list of declarations, each of which has the form: + ;; (type . items) Where type is a data-type, and items is a list of + ;; symbol names. The item order corresponds to the order of fields + ;; in the event sent by the server. An item may be a list of items. + ;; In this case, each item is aliased to the same event field. + ;; This is used to give all events an EVENT-WINDOW item. + ;; See the INPUT file for lots of examples. + (declare (type (or keyword list) event-codes) + (type (alist (field-type symbol) (field-names list)) + declares)) + (when (atom event-codes) (setq event-codes (list event-codes))) + (setq event-codes (mapcar #'canonicalize-event-name event-codes)) + (let* ((keywords nil) + (name (first event-codes)) + (get-macro (xintern name '-event-get-macro)) + (get-function (xintern name '-event-get)) + (put-function (xintern name '-event-put))) + (multiple-value-bind (get-code get-index get-sizes) + (get-put-items + 2 declares nil + #'(lambda (type index item args) + (flet ((event-get (type index item args) + (unless (member type '(pad8 pad16)) + `(,(kintern item) + (,(getify type) ,index ,@args))))) + (if (atom item) + (event-get type index item args) + (mapcan #'(lambda (item) + (event-get type index item args)) + item))))) + (declare (ignore get-index)) + (multiple-value-bind (put-code put-index put-sizes) + (get-put-items + 2 declares t + #'(lambda (type index item args) + (unless (member type '(pad8 pad16)) + (if (atom item) + (progn + (push item keywords) + `((,(putify type) ,index ,item ,@args))) + (let ((names (mapcar #'(lambda (name) (kintern name)) + item))) + (setq keywords (append item keywords)) + `((,(putify type) ,index + (check-consistency ',names ,@item) ,@args))))))) + (declare (ignore put-index)) + `(within-definition (,name declare-event) + (defun ,get-macro (display event-key variable) + ;; Note: we take pains to macroexpand the get-code here to enable application + ;; code to be compiled without having the CLX macros file loaded. + (subst display '%buffer + (getf `(:display (the display ,display) + :event-key (the keyword ,event-key) + :event-code (the card8 (logand #x7f (read-card8 0))) + :send-event-p (the boolean (logbitp 7 (read-card8 0))) + ,@',(mapcar #'macroexpand get-code)) + variable))) + + (defun ,get-function (display event handler) + (declare (type display display) + (type reply-buffer event)) + (declare (type function handler) + (downward-funarg handler)) + (reading-event (event :display display :sizes (8 16 ,@get-sizes)) + (funcall handler + :display display + :event-key (svref *event-key-vector* (event-code event)) + :event-code (logand #x7f (card8-get 0)) + :send-event-p (logbitp 7 (card8-get 0)) + ,@get-code))) + + (defun ,put-function (display &key ,@(setq keywords (nreverse keywords)) + &allow-other-keys) + (declare (type display display)) + ,(when (member 'sequence keywords) + `(unless sequence (setq sequence (display-request-number display)))) + (with-buffer-output (display :sizes ,put-sizes + :index (index+ (buffer-boffset display) 12)) + ,@put-code)) + + ,@(mapcar #'(lambda (name) + (allocate-extension-event-code name) + `(let ((event-code (or (get ',name 'event-code) + (allocate-extension-event-code ',name)))) + (setf (svref *event-macro-vector* event-code) + (function ,get-macro)) + (setf (svref *event-handler-vector* event-code) + (function ,get-function)) + (setf (svref *event-send-vector* event-code) + (function ,put-function)))) + event-codes) + ',name))))) + +(defun check-consistency (names &rest args) + ;; Ensure all args are nil or have the same value. + ;; Returns the consistent non-nil value. + (let ((value (car args))) + (dolist (arg (cdr args)) + (if value + (when (and arg (not (eq arg value))) + (x-error 'inconsistent-parameters + :parameters (mapcan #'list names args))) + (setq value arg))) + value)) + +(declare-event (:key-press :key-release :button-press :button-release) + ;; for key-press and key-release, code is the keycode + ;; for button-press and button-release, code is the button number + (data code) + (card16 sequence) + (card32 time) + (window root (window event-window)) + ((or null window) child) + (int16 root-x root-y x y) + (card16 state) + (boolean same-screen-p) + ) + +(declare-event :motion-notify + ((data boolean) hint-p) + (card16 sequence) + (card32 time) + (window root (window event-window)) + ((or null window) child) + (int16 root-x root-y x y) + (card16 state) + (boolean same-screen-p)) + +(declare-event (:enter-notify :leave-notify) + ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind) + (card16 sequence) + (card32 time) + (window root (window event-window)) + ((or null window) child) + (int16 root-x root-y x y) + (card16 state) + ((member8 :normal :grab :ungrab) mode) + ((bit 0) focus-p) + ((bit 1) same-screen-p)) + +(declare-event (:focus-in :focus-out) + ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual + :pointer :pointer-root :none)) + kind) + (card16 sequence) + (window (window event-window)) + ((member8 :normal :while-grabbed :grab :ungrab) mode)) + +(declare-event :keymap-notify + ((bit-vector256 0) keymap)) + +(declare-event :exposure + (card16 sequence) + (window (window event-window)) + (card16 x y width height count)) + +(declare-event :graphics-exposure + (card16 sequence) + (drawable (drawable event-window)) + (card16 x y width height) + (card16 minor) ;; Minor opcode + (card16 count) + (card8 major)) + +(declare-event :no-exposure + (card16 sequence) + (drawable (drawable event-window)) + (card16 minor) + (card8 major)) + +(declare-event :visibility-notify + (card16 sequence) + (window (window event-window)) + ((member8 :unobscured :partially-obscured :fully-obscured) state)) + +(declare-event :create-notify + (card16 sequence) + (window (parent event-window) window) + (int16 x y) + (card16 width height border-width) + (boolean override-redirect-p)) + +(declare-event :destroy-notify + (card16 sequence) + (window event-window window)) + +(declare-event :unmap-notify + (card16 sequence) + (window event-window window) + (boolean configure-p)) + +(declare-event :map-notify + (card16 sequence) + (window event-window window) + (boolean override-redirect-p)) + +(declare-event :map-request + (card16 sequence) + (window (parent event-window) window)) + +(declare-event :reparent-notify + (card16 sequence) + (window event-window window parent) + (int16 x y) + (boolean override-redirect-p)) + +(declare-event :configure-notify + (card16 sequence) + (window event-window window) + ((or null window) above-sibling) + (int16 x y) + (card16 width height border-width) + (boolean override-redirect-p)) + +(declare-event :configure-request + ((data (member :above :below :top-if :bottom-if :opposite)) stack-mode) + (card16 sequence) + (window (parent event-window) window) + ((or null window) above-sibling) + (int16 x y) + (card16 width height border-width value-mask)) + +(declare-event :gravity-notify + (card16 sequence) + (window event-window window) + (int16 x y)) + +(declare-event :resize-request + (card16 sequence) + (window (window event-window)) + (card16 width height)) + +(declare-event :circulate-notify + (card16 sequence) + (window event-window window parent) + ((member16 :top :bottom) place)) + +(declare-event :circulate-request + (card16 sequence) + (window (parent event-window) window) + (pad16 1 2) + ((member16 :top :bottom) place)) + +(declare-event :property-notify + (card16 sequence) + (window (window event-window)) + (keyword atom) ;; keyword + (card32 time) + ((member16 :new-value :deleted) state)) + +(declare-event :selection-clear + (card16 sequence) + (card32 time) + (window (window event-window)) + (keyword selection) ;; keyword + ) + +(declare-event :selection-request + (card16 sequence) + (card32 time) + (window (window event-window) requestor) + (keyword selection target) + ((or null keyword) property) + ) + +(declare-event :selection-notify + (card16 sequence) + (card32 time) + (window (window event-window)) + (keyword selection target) + ((or null keyword) property) + ) + +(declare-event :colormap-notify + (card16 sequence) + (window (window event-window)) + ((or null colormap) colormap) + (boolean new-p installed-p)) + +(declare-event :client-message + (data format) + (card16 sequence) + (window (window event-window)) + (keyword type) + ((client-message-sequence format) data)) + +(declare-event :mapping-notify + (card16 sequence) + ((member8 :modifier :keyboard :pointer) request) + (card8 start) ;; first key-code + (card8 count)) + + +;; +;; EVENT-LOOP +;; + +(defun event-loop-setup (display) + (declare (type display display) + (values progv-vars progv-vals + current-event-symbol current-event-discarded-p-symbol)) + (let* ((progv-vars (display-current-event-symbol display)) + (current-event-symbol (first progv-vars)) + (current-event-discarded-p-symbol (second progv-vars))) + (declare (type list progv-vars) + (type symbol current-event-symbol current-event-discarded-p-symbol)) + (values + progv-vars + (list (if (boundp current-event-symbol) + ;; The current event is already bound, so bind it to the next + ;; event. + (let ((event (symbol-value current-event-symbol))) + (declare (type (or null reply-buffer) event)) + (and event (reply-next (the reply-buffer event)))) + ;; The current event isn't bound, so bind it to the head of the + ;; event queue. + (display-event-queue-head display)) + nil) + current-event-symbol + current-event-discarded-p-symbol))) + +(defun event-loop-step-before (display timeout force-output-p current-event-symbol) + (declare (type display display) + (type (or null number) timeout) + (type boolean force-output-p) + (type symbol current-event-symbol) + (values event eof-or-timeout)) + (unless (symbol-value current-event-symbol) + (let ((eof-or-timeout (wait-for-event display timeout force-output-p))) + (when eof-or-timeout + (return-from event-loop-step-before (values nil eof-or-timeout)))) + (setf (symbol-value current-event-symbol) (display-new-events display))) + (let ((event (symbol-value current-event-symbol))) + (declare (type reply-buffer event)) + (with-event-queue-internal (display) + (when (eq event (display-new-events display)) + (setf (display-new-events display) (reply-next event)))) + (values event nil))) + +(defvar *event-loop-version* 0) + +(defun dequeue-event (display event) + (declare (type display display) + (type reply-buffer event) + (values next)) + ;; Remove the current event from the event queue + (with-event-queue-internal (display) + (let ((next (reply-next event)) + (head (display-event-queue-head display))) + (declare (type (or null reply-buffer) next head)) + (when (eq event (display-new-events display)) + (setf (display-new-events display) next)) + (cond ((eq event head) + (threaded-dequeue (display-event-queue-head display) + (display-event-queue-tail display) + reply-next reply-buffer)) + ((null head) + (setq next nil)) + (t + (do* ((previous head current) + (current (reply-next previous) (reply-next previous))) + ((or (null current) (eq event current)) + (when (eq event current) + (when (eq current (display-event-queue-tail display)) + (setf (display-event-queue-tail display) previous)) + (setf (reply-next previous) next))) + (declare (type reply-buffer previous) + (type (or null reply-buffer) current))))) + next))) + +(defun event-loop-step-after + (display event discard-p current-event-symbol current-event-discarded-p-symbol + &optional aborted) + (declare (type display display) + (type reply-buffer event) + (type boolean discard-p aborted) + (type symbol current-event-symbol current-event-discarded-p-symbol)) + (when (and discard-p + (not aborted) + (not (symbol-value current-event-discarded-p-symbol))) + (discard-current-event display)) + (let ((next (reply-next event))) + (declare (type (or null reply-buffer) next)) + (when (symbol-value current-event-discarded-p-symbol) + (setf (symbol-value current-event-discarded-p-symbol) nil) + (ecase *event-loop-version* + ;; in version 0 discard-current-event dequeues the event. + (0 ) + ;; in version 1 event-loop-step-after dequeues the event. + (1 (setq next (dequeue-event display event)))) + (deallocate-event event)) + (setf (symbol-value current-event-symbol) next))) + +(defmacro event-loop ((display event timeout force-output-p discard-p) &body body) + ;; Bind EVENT to the events for DISPLAY. + ;; This is the "GUTS" of process-event and event-case. + `(let ((*event-loop-version* 1) + (.display. ,display) + (.timeout. ,timeout) + (.force-output-p. ,force-output-p) + (.discard-p. ,discard-p)) + (declare (type display .display.) + (type (or null number) .timeout.) + (type boolean .force-output-p. .discard-p.)) + (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.))) + (multiple-value-bind (.progv-vars. .progv-vals. + .current-event-symbol. .current-event-discarded-p-symbol.) + (event-loop-setup .display.) + (declare (type list .progv-vars. .progv-vals.) + (type symbol .current-event-symbol. .current-event-discarded-p-symbol.)) + (progv .progv-vars. .progv-vals. + (loop + (multiple-value-bind (.event. .eof-or-timeout.) + (event-loop-step-before + .display. .timeout. .force-output-p. + .current-event-symbol.) + (declare (type (or null reply-buffer) .event.)) + (when (null .event.) (return (values nil .eof-or-timeout.))) + (let ((.aborted. t)) + (unwind-protect + (progn + (let ((,event .event.)) + (declare (type reply-buffer ,event)) + ,@body) + (setq .aborted. nil)) + (event-loop-step-after + .display. .event. .discard-p. + .current-event-symbol. .current-event-discarded-p-symbol. + .aborted.)))))))))) + +(defun discard-current-event (display) + ;; Discard the current event for DISPLAY. + ;; Returns NIL when the event queue is empty, else T. + ;; To ensure events aren't ignored, application code should only call + ;; this when throwing out of event-case or process-next-event, or from + ;; inside even-case, event-cond or process-event when :peek-p is T and + ;; :discard-p is NIL. + (declare (type display display) + (values boolean)) + (let* ((symbols (display-current-event-symbol display)) + (event + (let ((current-event-symbol (first symbols))) + (declare (type symbol current-event-symbol)) + (when (boundp current-event-symbol) + (symbol-value current-event-symbol))))) + (declare (type list symbols) + (type (or null reply-buffer) event)) + (unless (null event) + (ecase *event-loop-version* + ;; in version 0 discard-current-event dequeues the event. + (0 (setf (reply-next (the reply-buffer event)) + (dequeue-event display event))) + ;; in version 1 event-loop-step-after dequeues the event. + (1 )) + ;; Set the discarded-p flag + (let ((current-event-discarded-p-symbol (second symbols))) + (declare (type symbol current-event-discarded-p-symbol)) + (when (boundp current-event-discarded-p-symbol) + (setf (symbol-value current-event-discarded-p-symbol) t))) + ;; Return whether the event queue is empty + (not (null (reply-next (the reply-buffer event))))))) + +;; +;; PROCESS-EVENT +;; +(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t)) + ;; If force-output-p is true, first invokes display-force-output. Invokes handler + ;; on each queued event until handler returns non-nil, and that returned object is + ;; then returned by process-event. If peek-p is true, then the event is not + ;; removed from the queue. If discard-p is true, then events for which handler + ;; returns nil are removed from the queue, otherwise they are left in place. Hangs + ;; until non-nil is generated for some event, or for the specified timeout (in + ;; seconds, if given); however, it is acceptable for an implementation to wait only + ;; once on network data, and therefore timeout prematurely. Returns nil on + ;; timeout. If handler is a sequence, it is expected to contain handler functions + ;; specific to each event class; the event code is used to index the sequence, + ;; fetching the appropriate handler. Handler is called with raw resource-ids, not + ;; with resource objects. The arguments to the handler are described using declare-event. + ;; + ;; T for peek-p means the event (for which the handler returns non-nil) is not removed + ;; from the queue (it is left in place), NIL means the event is removed. + + (declare (type display display) + (type (or null number) timeout) + (type boolean peek-p discard-p force-output-p)) + (declare (type t handler) + (downward-funarg #+Genera * #-Genera handler)) + (event-loop (display event timeout force-output-p discard-p) + (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT + (event-decoder (and (index< event-code (length *event-handler-vector*)) + (svref *event-handler-vector* event-code)))) + (declare (type array-index event-code) + (type (or null function) event-decoder)) + (if event-decoder + (let ((event-handler (if (functionp handler) + handler + (and (type? handler 'sequence) + (< event-code (length handler)) + (elt handler event-code))))) + (if event-handler + (let ((result (funcall event-decoder display event event-handler))) + (when result + (unless peek-p + (discard-current-event display)) + (return result))) + (cerror "Ignore this event" + "No handler for ~s event" + (svref *event-key-vector* event-code)))) + (cerror "Ignore this event" + "Server Error: event with unknown event code ~d received." + event-code))))) + +(defun make-event-handlers (&key (type 'array) default) + (declare (type t type) ;Sequence type specifier + (type function default) + (values sequence)) ;Default handler for initial content + ;; Makes a handler sequence suitable for process-event + (make-sequence type *max-events* :initial-element default)) + +(defun event-handler (handlers event-key) + (declare (type sequence handlers) + (type event-key event-key) + (values function)) + ;; Accessor for a handler sequence + (elt handlers (position event-key *event-key-vector* :test #'eq))) + +(defun set-event-handler (handlers event-key handler) + (declare (type sequence handlers) + (type event-key event-key) + (type function handler) + (values handler)) + (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler)) + +(defsetf event-handler set-event-handler) + +;; +;; EVENT-CASE +;; + +(defmacro event-case ((&rest args) &body clauses) + ;; If force-output-p is true, first invokes display-force-output. Executes the + ;; matching clause for each queued event until a clause returns non-nil, and that + ;; returned object is then returned by event-case. If peek-p is true, then the + ;; event is not removed from the queue. If discard-p is true, then events for + ;; which the clause returns nil are removed from the queue, otherwise they are left + ;; in place. Hangs until non-nil is generated for some event, or for the specified + ;; timeout (in seconds, if given); however, it is acceptable for an implementation + ;; to wait only once on network data, and therefore timeout prematurely. Returns + ;; nil on timeout. In each clause, event-or-events is an event-key or a list of + ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise + ;; (but only in the last clause). The keys are not evaluated, and it is an error + ;; for the same key to appear in more than one clause. Args is the list of event + ;; components of interest; corresponding values (if any) are bound to variables + ;; with these names (i.e., the args are variable names, not keywords, the keywords + ;; are derived from the variable names). An arg can also be a (keyword var) form, + ;; as for keyword args in a lambda lists. If no t/otherwise clause appears, it is + ;; equivalent to having one that returns nil. + (declare (arglist (display &key timeout peek-p discard-p (force-output-p t)) + (event-or-events ((&rest args) |...|) &body body) |...|)) + ;; Event-case is just event-cond with the whole body in the test-form + `(event-cond ,args + ,@(mapcar + #'(lambda (clause) + `(,(car clause) ,(cadr clause) (progn ,@(cddr clause)))) + clauses))) + +;; +;; EVENT-COND +;; + +(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) + &body clauses) + ;; The clauses of event-cond are of the form: + ;; (event-or-events binding-list test-form . body-forms) + ;; + ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they + ;; need not be typed as keywords) or the symbol t + ;; or otherwise (but only in the last clause). If + ;; no t/otherwise clause appears, it is equivalent + ;; to having one that returns nil. The keys are + ;; not evaluated, and it is an error for the same + ;; key to appear in more than one clause. + ;; + ;; BINDING-LIST The list of event components of interest. + ;; corresponding values (if any) are bound to + ;; variables with these names (i.e., the binding-list + ;; has variable names, not keywords, the keywords are + ;; derived from the variable names). An arg can also + ;; be a (keyword var) form, as for keyword args in a + ;; lambda list. + ;; + ;; The matching TEST-FORM for each queued event is executed until a + ;; clause's test-form returns non-nil. Then the BODY-FORMS are + ;; evaluated, returning the (possibly multiple) values of the last + ;; form from event-cond. If there are no body-forms then, if the + ;; test-form is non-nil, the value of the test-form is returned as a + ;; single value. + ;; + ;; Options: + ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no + ;; input is pending. + ;; + ;; PEEK-P When true, then the event is not removed from the queue. + ;; + ;; DISCARD-P When true, then events for which the clause returns nil + ;; are removed from the queue, otherwise they are left in place. + ;; + ;; TIMEOUT If NIL, hang until non-nil is generated for some event's + ;; test-form. Otherwise return NIL after TIMEOUT seconds have + ;; elapsed. + ;; + (declare (arglist (display &key timeout peek-p discard-p force-output-p) + (event-or-events (&rest args) test-form &body body) |...|)) + (let ((event (gensym)) + (disp (gensym)) + (peek (gensym))) + `(let ((,disp ,display) + (,peek ,peek-p)) + (declare (type display ,disp)) + (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p) + (event-dispatch (,disp ,event ,peek) ,@clauses))))) + +(defun get-event-code (event) + ;; Returns the event code given an event-key + (declare (type event-key event)) + (declare (values card8)) + (or (get event 'event-code) + (x-type-error event 'event-key))) + +(defun universal-event-get-macro (display event-key variable) + (getf + `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code + (the card8 (logand 127 (read-card8 0))) :send-event-p + (the boolean (logbitp 7 (read-card8 0)))) + variable)) + +(defmacro event-dispatch ((display event peek-p) &body clauses) + ;; Helper macro for event-case + ;; CLAUSES are of the form: + ;; (event-or-events binding-list test-form . body-forms) + (let ((event-key (gensym)) + (all-events (make-array *max-events* :element-type 'bit :initial-element 0))) + `(reading-event (,event) + (let ((,event-key (svref *event-key-vector* (event-code ,event)))) + (case ,event-key + ,@(mapcar + #'(lambda (clause) ; Translate event-cond clause to case clause + (let* ((events (first clause)) + (arglist (second clause)) + (test-form (third clause)) + (body-forms (cdddr clause))) + (flet ((event-clause (display peek-p first-form rest-of-forms) + (if rest-of-forms + `(when ,first-form + (unless ,peek-p (discard-current-event ,display)) + (return (progn ,@rest-of-forms))) + ;; No body forms, return the result of the test form + (let ((result (gensym))) + `(let ((,result ,first-form)) + (when ,result + (unless ,peek-p (discard-current-event ,display)) + (return ,result))))))) + + (if (member events '(otherwise t)) + ;; code for OTHERWISE clause. + ;; Find all events NOT used by other clauses + (let ((keys (do ((i 0 (1+ i)) + (key nil) + (result nil)) + ((>= i *max-events*) result) + (setq key (svref *event-key-vector* i)) + (when (and key (zerop (aref all-events i))) + (push key result))))) + `(otherwise + (binding-event-values + (,display ,event-key ,(or keys :universal) ,@arglist) + ,(event-clause display peek-p test-form body-forms)))) + + ;; Code for normal clauses + (let (true-events) ;; canonicalize event-names + (if (consp events) + (progn + (setq true-events (mapcar #'canonicalize-event-name events)) + (dolist (event true-events) + (setf (aref all-events (get-event-code event)) 1))) + (setf true-events (canonicalize-event-name events) + (aref all-events (get-event-code true-events)) 1)) + `(,true-events + (binding-event-values + (,display ,event-key ,true-events ,@arglist) + ,(event-clause display peek-p test-form body-forms)))))))) + clauses)))))) + +(defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body) + ;; Execute BODY with the variables in VALUE-LIST bound to components of the + ;; EVENT-KEYS events. + (unless (consp event-keys) (setq event-keys (list event-keys))) + (flet ((var-key (var) (kintern (if (consp var) (first var) var))) + (var-symbol (var) (if (consp var) (second var) var))) + ;; VARS is an alist of: + ;; (component-key ((event-key event-key ...) . extraction-code) + ;; ((event-key event-key ...) . extraction-code) ...) + ;; There should probably be accessor macros for this, instead of things like cdadr. + (let ((vars (mapcar #'(lambda (var) (list var)) value-list)) + (multiple-p nil)) + ;; Fill in the VARS alist with event-keys and extraction-code + (do ((keys event-keys (cdr keys)) + (temp nil)) + ((endp keys)) + (let* ((key (car keys)) + (binder (case key + (:universal #'universal-event-get-macro) + (otherwise (svref *event-macro-vector* (get-event-code key)))))) + (dolist (var vars) + (let ((code (funcall binder display event-key (var-key (car var))))) + (unless code (warn "~a isn't a component of the ~s event" + (var-key (car var)) key)) + (if (setq temp (member code (cdr var) :key #'cdr :test #'equal)) + (push key (caar temp)) + (push `((,key) . ,code) (cdr var))))))) + ;; Bind all the values + `(let ,(mapcar #'(lambda (var) + (if (cddr var) ;; if more than one binding form + (progn (setq multiple-p t) + (var-symbol (car var))) + (list (var-symbol (car var)) (cdadr var)))) + vars) + ;; When some values come from different places, generate code to set them + ,(when multiple-p + `(case ,event-key + ,@(do ((keys event-keys (cdr keys)) + (clauses nil) ;; alist of (event-keys bindings) + (clause nil nil) + (temp)) + ((endp keys) + (dolist (clause clauses) + (unless (cdar clause) ;; Atomize single element lists + (setf (car clause) (caar clause)))) + clauses) + ;; Gather up all the bindings associated with (car keys) + (dolist (var vars) + (when (cddr var) ;; when more than one binding form + (dolist (events (cdr var)) + (when (member (car keys) (car events)) + ;; Optimize for event-window being the same as some other binding + (if (setq temp (member (cdr events) clause + :key #'caddr + :test #'equal)) + (setq clause + (nconc clause `((setq ,(car var) ,(second (car temp)))))) + (push `(setq ,(car var) ,(cdr events)) clause)))))) + ;; Merge bindings for (car keys) with other bindings + (when clause + (if (setq temp (member clause clauses :key #'cdr :test #'equal)) + (push (car keys) (caar temp)) + (push `((,(car keys)) . ,clause) clauses)))))) + ,@body)))) + + +;;;----------------------------------------------------------------------------- +;;; Error Handling +;;;----------------------------------------------------------------------------- + +(eval-when (eval compile load) +(defparameter + *xerror-vector* + '#(unknown-error + request-error ; 1 bad request code + value-error ; 2 integer parameter out of range + window-error ; 3 parameter not a Window + pixmap-error ; 4 parameter not a Pixmap + atom-error ; 5 parameter not an Atom + cursor-error ; 6 parameter not a Cursor + font-error ; 7 parameter not a Font + match-error ; 8 parameter mismatch + drawable-error ; 9 parameter not a Pixmap or Window + access-error ; 10 attempt to access private resource" + alloc-error ; 11 insufficient resources + colormap-error ; 12 no such colormap + gcontext-error ; 13 parameter not a GContext + id-choice-error ; 14 invalid resource ID for this connection + name-error ; 15 font or color name does not exist + length-error ; 16 request length incorrect; + ; internal Xlib error + implementation-error ; 17 server is defective + )) +) + +(defun make-error (display event asynchronous) + (declare (type display display) + (type reply-buffer event) + (type boolean asynchronous)) + (reading-event (event) + (let* ((error-code (read-card8 1)) + (error-key (get-error-key display error-code)) + (error-decode-function (get error-key 'error-decode-function)) + (params (funcall error-decode-function display event))) + (list* error-code error-key + :asynchronous asynchronous :current-sequence (display-request-number display) + params)))) + +(defun report-error (display error-code error-key &rest params) + (declare (type display display) + (dynamic-extent params)) + ;; All errors (synchronous and asynchronous) are processed by calling + ;; an error handler in the display. The handler is called with the display + ;; as the first argument and the error-key as its second argument. If handler is + ;; an array it is expected to contain handler functions specific to + ;; each error; the error code is used to index the array, fetching the + ;; appropriate handler. Any results returned by the handler are ignored;; + ;; it is assumed the handler either takes care of the error completely, + ;; or else signals. For all core errors, additional keyword/value argument + ;; pairs are: + ;; :major integer + ;; :minor integer + ;; :sequence integer + ;; :current-sequence integer + ;; :asynchronous (member t nil) + ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window + ;; errors another pair is: + ;; :resource-id integer + ;; For :atom errors, another pair is: + ;; :atom-id integer + ;; For :value errors, another pair is: + ;; :value integer + (let* ((handler (display-error-handler display)) + (handler-function + (if (type? handler 'sequence) + (elt handler error-code) + handler))) + (apply handler-function display error-key params))) + +(defun request-name (code &optional display) + (if (< code (length *request-names*)) + (svref *request-names* code) + (dolist (extension (and display (display-extension-alist display)) "unknown") + (when (= code (second extension)) + (return (first extension)))))) + +#-(or ansi-common-lisp excl lcl3.0) +(define-condition request-error (x-error) + (display + error-key + major + minor + sequence + current-sequence + asynchronous) + (:report report-request-error)) + +(defun report-request-error (condition stream) + (let ((error-key (request-error-error-key condition)) + (asynchronous (request-error-asynchronous condition)) + (major (request-error-major condition)) + (minor (request-error-minor condition)) + (sequence (request-error-sequence condition)) + (current-sequence (request-error-current-sequence condition))) + (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]" + asynchronous error-key (= sequence current-sequence) + sequence current-sequence major minor + (request-name major (request-error-display condition))))) + +;; Since the :report arg is evaluated as (function report-request-error) the +;; define-condition must come after the function definition. +#+(or ansi-common-lisp excl lcl3.0) +(define-condition request-error (x-error) + (display + error-key + major + minor + sequence + current-sequence + asynchronous) + (:report report-request-error)) + +(define-condition resource-error (request-error) + (resource-id) + (:report (lambda (condition stream) + (report-request-error condition stream) + (format stream " ID #x~x" (resource-error-resource-id condition))))) + +(define-condition unknown-error (request-error) + (error-code) + (:report (lambda (condition stream) + (report-request-error condition stream) + (format stream " Error Code ~d." (unknown-error-error-code condition))))) + +(define-condition access-error (request-error)) + +(define-condition alloc-error (request-error)) + +(define-condition atom-error (request-error) + (atom-id) + (:report (lambda (condition stream) + (report-request-error condition stream) + (format stream " Atom-ID #x~x" (atom-error-atom-id condition))))) + +(define-condition colormap-error (resource-error)) + +(define-condition cursor-error (resource-error)) + +(define-condition drawable-error (resource-error)) + +(define-condition font-error (resource-error)) + +(define-condition gcontext-error (resource-error)) + +(define-condition id-choice-error (resource-error)) + +(define-condition illegal-request-error (request-error)) + +(define-condition length-error (request-error)) + +(define-condition match-error (request-error)) + +(define-condition name-error (request-error)) + +(define-condition pixmap-error (resource-error)) + +(define-condition value-error (request-error) + (value) + (:report (lambda (condition stream) + (report-request-error condition stream) + (format stream " Value ~d." (value-error-value condition))))) + +(define-condition window-error (resource-error)) + +(define-condition implementation-error (request-error)) + +;;----------------------------------------------------------------------------- +;; Internal error conditions signaled by CLX + +(define-condition x-type-error (type-error) + (type-string) + (:report (lambda (condition stream) + (format stream "~s isn't a ~a" + (type-error-datum condition) + (or (x-type-error-type-string condition) + (type-error-expected-type condition)))))) + +(define-condition closed-display (x-error) + (display) + (:report (lambda (condition stream) + (format stream "Attempt to use closed display ~s" + (closed-display-display condition))))) + +(define-condition lookup-error (x-error) + (id display type object) + (:report (lambda (condition stream) + (format stream "ID ~d from display ~s should have been a ~s, but was ~s" + (lookup-error-id condition) + (lookup-error-display condition) + (lookup-error-type condition) + (lookup-error-object condition))))) + +(define-condition connection-failure (x-error) + (major-version + minor-version + host + display + reason) + (:report (lambda (condition stream) + (format stream "Connection failure to X~d.~d server ~a display ~d: ~a" + (connection-failure-major-version condition) + (connection-failure-minor-version condition) + (connection-failure-host condition) + (connection-failure-display condition) + (connection-failure-reason condition))))) + +(define-condition reply-length-error (x-error) + (reply-length + expected-length + display) + (:report (lambda (condition stream) + (format stream "Reply length was ~d when ~d words were expected for display ~s" + (reply-length-error-reply-length condition) + (reply-length-error-expected-length condition) + (reply-length-error-display condition))))) + +(define-condition reply-timeout (x-error) + (timeout + display) + (:report (lambda (condition stream) + (format stream "Timeout after waiting ~d seconds for a reply for display ~s" + (reply-timeout-timeout condition) + (reply-timeout-display condition))))) + +(define-condition sequence-error (x-error) + (display + req-sequence + msg-sequence) + (:report (lambda (condition stream) + (format stream "Reply out of sequence for display ~s.~% Expected ~d, Got ~d" + (sequence-error-display condition) + (sequence-error-req-sequence condition) + (sequence-error-msg-sequence condition))))) + +(define-condition unexpected-reply (x-error) + (display + msg-sequence + req-sequence + length) + (:report (lambda (condition stream) + (format stream "Display ~s received a server reply when none was expected.~@ + Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes." + (unexpected-reply-display condition) + (unexpected-reply-req-sequence condition) + (unexpected-reply-msg-sequence condition) + (unexpected-reply-length condition))))) + +(define-condition missing-parameter (x-error) + (parameter) + (:report (lambda (condition stream) + (let ((parm (missing-parameter-parameter condition))) + (if (consp parm) + (format stream "One or more of the required parameters ~a is missing." + parm) + (format stream "Required parameter ~a is missing or null." parm)))))) + +;; This can be signalled anywhere a pseudo font access fails. +(define-condition invalid-font (x-error) + (font) + (:report (lambda (condition stream) + (format stream "Can't access font ~s" (invalid-font-font condition))))) + +(define-condition device-busy (x-error) + (display) + (:report (lambda (condition stream) + (format stream "Device busy for display ~s" + (device-busy-display condition))))) + +(define-condition unimplemented-event (x-error) + (display + event-code) + (:report (lambda (condition stream) + (format stream "Event code ~d not implemented for display ~s" + (unimplemented-event-event-code condition) + (unimplemented-event-display condition))))) + +(define-condition undefined-event (x-error) + (display + event-name) + (:report (lambda (condition stream) + (format stream "Event code ~d undefined for display ~s" + (undefined-event-event-name condition) + (undefined-event-display condition))))) + +(define-condition absent-extension (x-error) + (name display) + (:report (lambda (condition stream) + (format stream "Extension ~a isn't defined for display ~s" + (absent-extension-name condition) + (absent-extension-display condition))))) + +(define-condition inconsistent-parameters (x-error) + (parameters) + (:report (lambda (condition stream) + (format stream "inconsistent-parameters:~{ ~s~}" + (inconsistent-parameters-parameters condition))))) + +(defun get-error-key (display error-code) + (declare (type display display) + (type array-index error-code)) + ;; Return the error-key associated with error-code + (if (< error-code (length *xerror-vector*)) + (svref *xerror-vector* error-code) + ;; Search the extensions for the error + (dolist (entry (display-extension-alist display) 'unknown-error) + (let* ((event-name (first entry)) + (first-error (fourth entry)) + (errors (third (assoc event-name *extensions*)))) + (declare (type keyword event-name) + (type array-index first-error) + (type list errors)) + (when (and errors + (index<= first-error error-code + (index+ first-error (index- (length errors) 1)))) + (return (nth (index- error-code first-error) errors))))))) + +(defmacro define-error (error-key function) + ;; Associate a function with ERROR-KEY which will be called with + ;; parameters DISPLAY and REPLY-BUFFER and + ;; returns a plist of keyword/value pairs which will be passed on + ;; to the error handler. A compiler warning is printed when + ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION. + ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type + ;; macros for getting error fields. See DECODE-CORE-ERROR for + ;; an example. + (declare (type symbol error-key) + (type function function)) + ;; First ensure the name is for a declared extension + (unless (or (find error-key *xerror-vector*) + (dolist (extension *extensions*) + (when (member error-key (third extension)) + (return t)))) + (x-type-error error-key 'error-key)) + `(setf (get ',error-key 'error-decode-function) (function ,function))) + +;; All core errors use this, so we make it available to extensions. +(defun decode-core-error (display event &optional arg) + ;; All core errors have the following keyword/argument pairs: + ;; :major integer + ;; :minor integer + ;; :sequence integer + ;; In addition, many have an additional argument that comes from the + ;; same place in the event, but is named differently. When the ARG + ;; argument is specified, the keyword ARG with card32 value starting + ;; at byte 4 of the event is returned with the other keyword/argument + ;; pairs. + (declare (type display display) + (type reply-buffer event) + (type (or null keyword) arg)) + (declare (values keyword/arg-plist)) + display + (reading-event (event) + (let* ((sequence (read-card16 2)) + (minor-code (read-card16 8)) + (major-code (read-card8 10)) + (result (list :major major-code + :minor minor-code + :sequence sequence))) + (when arg + (setq result (list* arg (read-card32 4) result))) + result))) + +(defun decode-resource-error (display event) + (decode-core-error display event :resource-id)) + +(define-error unknown-error + (lambda (display event) + (list* :error-code (aref (reply-ibuf8 event) 1) + (decode-core-error display event)))) + +(define-error request-error decode-core-error) ; 1 bad request code + +(define-error value-error ; 2 integer parameter out of range + (lambda (display event) + (decode-core-error display event :value))) + +(define-error window-error decode-resource-error) ; 3 parameter not a Window + +(define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap + +(define-error atom-error ; 5 parameter not an Atom + (lambda (display event) + (decode-core-error display event :atom-id))) + +(define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor + +(define-error font-error decode-resource-error) ; 7 parameter not a Font + +(define-error match-error decode-core-error) ; 8 parameter mismatch + +(define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window + +(define-error access-error decode-core-error) ; 10 attempt to access private resource" + +(define-error alloc-error decode-core-error) ; 11 insufficient resources + +(define-error colormap-error decode-resource-error) ; 12 no such colormap + +(define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext + +(define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection + +(define-error name-error decode-core-error) ; 15 font or color name does not exist + +(define-error length-error decode-core-error) ; 16 request length incorrect; + ; internal Xlib error + +(define-error implementation-error decode-core-error) ; 17 server is defective diff --git a/clx/manager.lisp b/clx/manager.lisp new file mode 100644 index 0000000000000000000000000000000000000000..96832df3b2116c8af8c4b51758ceb2ee24a8889e --- /dev/null +++ b/clx/manager.lisp @@ -0,0 +1,851 @@ +;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- + +;;; Window Manager Property functions + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +(export '(wm-name ;These are all setf'able accessor functions + wm-icon-name + wm-client-machine + wm-command + wm-hints + wm-normal-hints + icon-sizes + wm-protocols + wm-colormap-windows + + wm-size-hints + wm-size-hints-p + make-wm-size-hints + wm-size-hints-user-specified-position-p + wm-size-hints-user-specified-size-p + wm-size-hints-min-width + wm-size-hints-min-height + wm-size-hints-max-width + wm-size-hints-max-height + wm-size-hints-width-inc + wm-size-hints-height-inc + wm-size-hints-min-aspect + wm-size-hints-max-aspect + wm-size-hints-base-width + wm-size-hints-base-height + wm-size-hints-win-gravity + + wm-hints + wm-hints-p + make-wm-hints + wm-hints-input + wm-hints-initial-state + wm-hints-icon-pixmap + wm-hints-icon-window + wm-hints-icon-x + wm-hints-icon-y + wm-hints-icon-mask + wm-hints-window-group + wm-hints-flags + + transient-for + + set-wm-properties + iconify-window + withdraw-window + + get-wm-class + set-wm-class + rgb-colormaps + + cut-buffer ;; Setf'able + rotate-cut-buffers + + ;; Obsolete + wm-zoom-hints + wm-size-hints-x + wm-size-hints-y + wm-size-hints-width + wm-size-hints-height + set-standard-properties + get-standard-colormap + set-standard-colormap + )) + +(defun wm-name (window) + (declare (type window window)) + (declare (values string)) + (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char)) + +(defsetf wm-name (window) (name) + (declare (type window window)) + (declare (values string)) + `(set-string-property ,window :WM_NAME ,name)) + +(defun set-string-property (window property string) + (declare (type window window) + (type keyword property) + (type stringable string)) + (change-property window property (string string) :STRING 8 :transform #'char->card8) + string) + +(defun wm-icon-name (window) + (declare (type window window)) + (declare (values string)) + (get-property window :WM_ICON_NAME :type :STRING + :result-type 'string :transform #'card8->char)) + +(defsetf wm-icon-name (window) (name) + `(set-string-property ,window :WM_ICON_NAME ,name)) + +(defun wm-client-machine (window) + (declare (type window window)) + (declare (values string)) + (get-property window :WM_CLIENT_MACHINE :type :STRING + :result-type 'string :transform #'card8->char)) + +(defsetf wm-client-machine (window) (name) + `(set-string-property ,window :WM_CLIENT_MACHINE ,name)) + +(defun get-wm-class (window) + (declare (type window window)) + (declare (values (or null name-string) (or null class-string))) + (let ((value (get-property window :WM_CLASS :type :STRING + :result-type 'string :transform #'card8->char))) + (declare (type (or null string) value)) + (when value + (let* ((name-len (position #.(card8->char 0) (the string value))) + (name (subseq (the string value) 0 name-len)) + (class (subseq (the string value) (1+ name-len) (1- (length value))))) + (values (and (plusp (length name)) name) + (and (plusp (length class)) class)))))) + +(defun set-wm-class (window resource-name resource-class) + (declare (type window window) + (type (or null stringable) resource-name resource-class)) + (set-string-property window :WM_CLASS + (concatenate 'string + (string (or resource-name "")) + #.(make-string 1 :initial-element (card8->char 0)) + (string (or resource-class "")) + #.(make-string 1 :initial-element (card8->char 0)))) + (values)) + +(defun wm-command (window) + ;; Returns a list whose car is the command and + ;; whose cdr is the list of arguments + (declare (type window window)) + (declare (values list)) + (do* ((command-string (get-property window :WM_COMMAND :type :STRING + :result-type 'string :transform #'card8->char)) + (command nil) + (start 0 (1+ end)) + (end 0) + (len (length command-string))) + ((>= start len) (nreverse command)) + (setq end (position #.(card8->char 0) command-string :start start)) + (push (subseq command-string start end) command))) + +(defsetf wm-command set-wm-command) +(defun set-wm-command (window command) + ;; Uses PRIN1 to a string-stream with the following bindings: + ;; (*print-length* nil) (*print-level* nil) (*print-radix* nil) + ;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp)) + ;; each element of command is seperated with NULL characters. + ;; This enables (mapcar #'read-from-string (wm-command window)) + ;; to recover a lisp command. + (declare (type window window) + (type list command)) + (set-string-property window :WM_COMMAND + (with-output-to-string (stream) + (let ((*print-length* nil) + (*print-level* nil) + (*print-radix* nil) + (*print-base* 10.) + (*print-array* t) + (*package* (find-package 'lisp)) + #+ti (ticl:*print-structure* t)) + (dolist (c command) + (prin1 c stream) + (write-char #.(card8->char 0) stream))))) + command) + +;;----------------------------------------------------------------------------- +;; WM_HINTS + +(def-clx-class (wm-hints) + (input nil :type (or null (member :off :on))) + (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive))) + (icon-pixmap nil :type (or null pixmap)) + (icon-window nil :type (or null window)) + (icon-x nil :type (or null card16)) + (icon-y nil :type (or null card16)) + (icon-mask nil :type (or null pixmap)) + (window-group nil :type (or null resource-id)) + (flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field + ;; may be extended in the future + ) + +(defun wm-hints (window) + (declare (type window window)) + (declare (values wm-hints)) + (let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector))) + (when prop + (decode-wm-hints prop (window-display window))))) + +(defsetf wm-hints set-wm-hints) +(defun set-wm-hints (window wm-hints) + (declare (type window window) + (type wm-hints wm-hints)) + (declare (values wm-hints)) + (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32) + wm-hints) + +(defun decode-wm-hints (vector display) + (declare (type (simple-vector 9) vector) + (type display display)) + (declare (values wm-hints)) + (let ((input-hint 0) + (state-hint 1) + (icon-pixmap-hint 2) + (icon-window-hint 3) + (icon-position-hint 4) + (icon-mask-hint 5) + (window-group-hint 6)) + (let ((flags (aref vector 0)) + (hints (make-wm-hints)) + (%buffer display)) + (declare (type card32 flags) + (type wm-hints hints) + (type display %buffer)) + (setf (wm-hints-flags hints) flags) + (when (logbitp input-hint flags) + (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1)))) + (when (logbitp state-hint flags) + (setf (wm-hints-initial-state hints) + (decode-type (member :dont-care :normal :zoom :iconic :inactive) + (aref vector 2)))) + (when (logbitp icon-pixmap-hint flags) + (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) + (when (logbitp icon-window-hint flags) + (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) + (when (logbitp icon-position-hint flags) + (setf (wm-hints-icon-x hints) (aref vector 5) + (wm-hints-icon-y hints) (aref vector 6))) + (when (logbitp icon-mask-hint flags) + (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) + (when (and (logbitp window-group-hint flags) (> (length vector) 7)) + (setf (wm-hints-window-group hints) (aref vector 8))) + hints))) + + +(defun encode-wm-hints (wm-hints) + (declare (type wm-hints wm-hints)) + (declare (values simple-vector)) + (let ((input-hint #b1) + (state-hint #b10) + (icon-pixmap-hint #b100) + (icon-window-hint #b1000) + (icon-position-hint #b10000) + (icon-mask-hint #b100000) + (window-group-hint #b1000000) + (mask #b1111111) + ) + (let ((vector (make-array 9 :initial-element 0)) + (flags 0)) + (declare (type (simple-vector 9) vector) + (type card16 flags)) + (when (wm-hints-input wm-hints) + (setf flags input-hint + (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) + (when (wm-hints-initial-state wm-hints) + (setf flags (logior flags state-hint) + (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) + (wm-hints-initial-state wm-hints)))) + (when (wm-hints-icon-pixmap wm-hints) + (setf flags (logior flags icon-pixmap-hint) + (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) + (when (wm-hints-icon-window wm-hints) + (setf flags (logior flags icon-window-hint) + (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) + (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints)) + (setf flags (logior flags icon-position-hint) + (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) + (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) + (when (wm-hints-icon-mask wm-hints) + (setf flags (logior flags icon-mask-hint) + (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) + (when (wm-hints-window-group wm-hints) + (setf flags (logior flags window-group-hint) + (aref vector 8) (wm-hints-window-group wm-hints))) + (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask))) + vector))) + +;;----------------------------------------------------------------------------- +;; WM_SIZE_HINTS + +(def-clx-class (wm-size-hints) + ;; Defaulted T to put the burden of remembering these on widget programmers. + (user-specified-position-p nil :type boolean) ;; True when user specified x y + (user-specified-size-p nil :type boolean) ;; True when user specified width height + (x nil :type (or null int16)) ;; Obsolete + (y nil :type (or null int16)) ;; Obsolete + (width nil :type (or null card16)) ;; Obsolete + (height nil :type (or null card16)) ;; Obsolete + (min-width nil :type (or null card16)) + (min-height nil :type (or null card16)) + (max-width nil :type (or null card16)) + (max-height nil :type (or null card16)) + (width-inc nil :type (or null card16)) + (height-inc nil :type (or null card16)) + (min-aspect nil :type (or null number)) + (max-aspect nil :type (or null number)) + (base-width nil :type (or null card16)) + (base-height nil :type (or null card16)) + (win-gravity nil :type (or null win-gravity))) + + +(defun wm-normal-hints (window) + (declare (type window window)) + (declare (values wm-size-hints)) + (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) + +(defsetf wm-normal-hints set-wm-normal-hints) +(defun set-wm-normal-hints (window hints) + (declare (type window window) + (type wm-size-hints hints)) + (declare (values wm-size-hints)) + (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) + hints) + +;;; OBSOLETE +(defun wm-zoom-hints (window) + (declare (type window window)) + (declare (values wm-size-hints)) + (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) + +;;; OBSOLETE +(defsetf wm-zoom-hints set-wm-zoom-hints) +;;; OBSOLETE +(defun set-wm-zoom-hints (window hints) + (declare (type window window) + (type wm-size-hints hints)) + (declare (values wm-size-hints)) + (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) + hints) + +(defun decode-wm-size-hints (vector) + (declare (type (or null (simple-vector *)) vector)) + (declare (values (or null wm-size-hints))) + (when vector + (let ((usposition 0) ;User Specified position + (ussize 1) ;User Specified size + (pposition 2) ;Program specified position + (psize 3) ;Program specified size + (pminsize 4) ;Program specified minimum size + (pmaxsize 5) ;Program specified maximum size + (presizeinc 6) ;Program specified resize increments + (paspect 7) ;Program specfied min and max aspect ratios + (pbasesize 8) ;Program specified base size + (pwingravity 9) ;Program specified window gravity + ) + (let ((flags (aref vector 0)) + (hints (make-wm-size-hints))) + (declare (type card16 flags) + (type wm-size-hints hints)) + (when (or (logbitp usposition flags) + (logbitp pposition flags)) + (setf (wm-size-hints-user-specified-position-p hints) (logbitp usposition flags) + (wm-size-hints-x hints) (aref vector 1) + (wm-size-hints-y hints) (aref vector 2))) + (when (or (logbitp ussize flags) + (logbitp psize flags)) + (setf (wm-size-hints-user-specified-size-p hints) (logbitp usposition flags) + (wm-size-hints-width hints) (aref vector 3) + (wm-size-hints-height hints) (aref vector 4))) + (when (logbitp pminsize flags) + (setf (wm-size-hints-min-width hints) (aref vector 5) + (wm-size-hints-min-height hints) (aref vector 6))) + (when (logbitp pmaxsize flags) + (setf (wm-size-hints-max-width hints) (aref vector 7) + (wm-size-hints-max-height hints) (aref vector 8))) + (when (logbitp presizeinc flags) + (setf (wm-size-hints-width-inc hints) (aref vector 9) + (wm-size-hints-height-inc hints) (aref vector 10))) + (when (logbitp paspect flags) + (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12)) + (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14)))) + (when (> (length vector) 15) + ;; This test is for backwards compatibility since old Xlib programs + ;; can set a size-hints structure that is too small. See ICCCM. + (when (logbitp pbasesize flags) + (setf (wm-size-hints-base-width hints) (aref vector 15) + (wm-size-hints-base-height hints) (aref vector 16))) + (when (logbitp pwingravity flags) + (setf (wm-size-hints-win-gravity hints) + (decode-type (member-vector *win-gravity-vector*) (aref vector 17))))) + hints)))) + +(defun encode-wm-size-hints (hints) + (declare (type wm-size-hints hints)) + (declare (values simple-vector)) + (let ((usposition #b1) ;User Specified position + (ussize #b10) ;User Specified size + (pposition #b100) ;Program specified position + (psize #b1000) ;Program specified size + (pminsize #b10000) ;Program specified minimum size + (pmaxsize #b100000) ;Program specified maximum size + (presizeinc #b1000000) ;Program specified resize increments + (paspect #b10000000) ;Program specfied min and max aspect ratios + (pbasesize #b100000000) ;Program specfied base size + (pwingravity #b1000000000) ;Program specfied window gravity + ) + (let ((vector (make-array 18 :initial-element 0)) + (flags 0)) + (declare (type (simple-vector 18) vector) + (type card16 flags)) + (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) + (setq flags (if (wm-size-hints-user-specified-position-p hints) usposition pposition)) + (setf (aref vector 1) (wm-size-hints-x hints) + (aref vector 2) (wm-size-hints-y hints))) + (when (and (wm-size-hints-width hints) (wm-size-hints-height hints)) + (setf flags (logior flags (if (wm-size-hints-user-specified-position-p hints) ussize psize)) + (aref vector 3) (wm-size-hints-width hints) + (aref vector 4) (wm-size-hints-height hints))) + + (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints)) + (setf flags (logior flags pminsize) + (aref vector 5) (wm-size-hints-min-width hints) + (aref vector 6) (wm-size-hints-min-height hints))) + (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints)) + (setf flags (logior flags pmaxsize) + (aref vector 7) (wm-size-hints-max-width hints) + (aref vector 8) (wm-size-hints-max-height hints))) + (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints)) + (setf flags (logior flags presizeinc) + (aref vector 9) (wm-size-hints-width-inc hints) + (aref vector 10) (wm-size-hints-height-inc hints))) + (let ((min-aspect (wm-size-hints-min-aspect hints)) + (max-aspect (wm-size-hints-max-aspect hints))) + (when (and min-aspect max-aspect) + (setf flags (logior flags paspect) + min-aspect (rationalize min-aspect) + max-aspect (rationalize max-aspect) + (aref vector 11) (numerator min-aspect) + (aref vector 12) (denominator min-aspect) + (aref vector 13) (numerator max-aspect) + (aref vector 14) (denominator max-aspect)))) + (when (and (wm-size-hints-base-width hints) + (wm-size-hints-base-height hints)) + (setf flags (logior flags pbasesize) + (aref vector 15) (wm-size-hints-base-width hints) + (aref vector 16) (wm-size-hints-base-height hints))) + (when (wm-size-hints-win-gravity hints) + (setf flags (logior flags pwingravity) + (aref vector 17) (encode-type + (member-vector *win-gravity-vector*) + (wm-size-hints-win-gravity hints)))) + (setf (aref vector 0) flags) + vector))) + +;;----------------------------------------------------------------------------- +;; Icon_Size + +;; Use the same intermediate structure as WM_SIZE_HINTS + +(defun icon-sizes (window) + (declare (type window window)) + (declare (values wm-size-hints)) + (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector))) + (declare (type (or null (simple-vector 6)) vector)) + (when vector + (make-wm-size-hints + :min-width (aref vector 0) + :min-height (aref vector 1) + :max-width (aref vector 2) + :max-height (aref vector 3) + :width-inc (aref vector 4) + :height-inc (aref vector 5))))) + +(defsetf icon-sizes set-icon-sizes) +(defun set-icon-sizes (window wm-size-hints) + (declare (type window window) + (type wm-size-hints wm-size-hints)) + (let ((vector (vector (wm-size-hints-min-width wm-size-hints) + (wm-size-hints-min-height wm-size-hints) + (wm-size-hints-max-width wm-size-hints) + (wm-size-hints-max-height wm-size-hints) + (wm-size-hints-width-inc wm-size-hints) + (wm-size-hints-height-inc wm-size-hints)))) + (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32) + wm-size-hints)) + +;;----------------------------------------------------------------------------- +;; WM-Protocols + +(defun wm-protocols (window) + (map 'list #'(lambda (id) (atom-name (window-display window) id)) + (get-property window :WM_PROTOCOLS :type :ATOM))) + +(defsetf wm-protocols set-wm-protocols) +(defun set-wm-protocols (window protocols) + (change-property window :WM_PROTOCOLS + (map 'list #'(lambda (atom) (intern-atom (window-display window) atom)) + protocols) + :ATOM 32) + protocols) + +;;----------------------------------------------------------------------------- +;; WM-Colormap-windows + +(defun wm-colormap-windows (window) + (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW + :transform #'(lambda (id) + (lookup-window (window-display window) id))))) + +(defsetf wm-colormap-windows set-wm-colormap-windows) +(defun set-wm-colormap-windows (window colormap-windows) + (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32 + :transform #'window-id) + colormap-windows) + +;;----------------------------------------------------------------------------- +;; Transient-For + +(defun transient-for (window) + (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list))) + (and prop (lookup-window (window-display window) (car prop))))) + +(defsetf transient-for set-transient-for) +(defun set-transient-for (window transient) + (declare (type window window transient)) + (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32) + transient) + +;;----------------------------------------------------------------------------- +;; Set-WM-Properties + +(defun set-wm-properties (window &rest options &key + name icon-name resource-name resource-class command + client-machine hints normal-hints zoom-hints + ;; the following are used for wm-normal-hints + user-specified-position-p + user-specified-size-p + x y width height min-width min-height max-width max-height + width-inc height-inc min-aspect max-aspect + base-width base-height win-gravity + ;; the following are used for wm-hints + input initial-state icon-pixmap icon-window + icon-x icon-y icon-mask window-group) + ;; Set properties for WINDOW. + (declare (arglist window &rest options &key + name icon-name resource-name resource-class command + client-machine hints normal-hints + ;; the following are used for wm-normal-hints + user-specified-position-p user-specified-size-p + min-width min-height max-width max-height + width-inc height-inc min-aspect max-aspect + base-width base-height win-gravity + ;; the following are used for wm-hints + input initial-state icon-pixmap icon-window + icon-x icon-y icon-mask window-group)) + (declare (type window window) + (type (or null stringable) name icon-name resource-name resource-class client-machine) + (type (or null list) command) + (type (or null wm-hints) hints) + (type (or null wm-size-hints) normal-hints zoom-hints) + (type (or null boolean) user-specified-position-p user-specified-size-p) + (type (or null int16) x y) + (type (or null card16) width height min-width min-height max-width max-height width-inc height-inc base-width base-height) + (type (or null win-gravity) win-gravity) + (type (or null number) min-aspect max-aspect) + (type (or null (member :off :on)) input) + (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state) + (type (or null pixmap) icon-pixmap icon-mask) + (type (or null window) icon-window) + (type (or null card16) icon-x icon-y) + (type (or null resource-id) window-group) + (dynamic-extent options)) + (when name (setf (wm-name window) name)) + (when icon-name (setf (wm-icon-name window) icon-name)) + (when client-machine (setf (wm-client-machine window) client-machine)) + (when (or resource-name resource-class) + (set-wm-class window resource-name resource-class)) + (when command (setf (wm-command window) command)) + ;; WM-HINTS + (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window + :icon-x :icon-y :icon-mask :window-group)) + (when (getf options arg) (return t))) + (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints)))) + (when input (setf (wm-hints-input wm-hints) input)) + (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) + (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) + (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) + (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) + (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) + (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) + (when window-group (setf (wm-hints-input wm-hints) window-group)) + (setf (wm-hints window) wm-hints)) + (when hints (setf (wm-hints window) hints))) + ;; WM-NORMAL-HINTS + (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height + :width-inc :height-inc :min-aspect :max-aspect + :user-specified-position-p :user-specified-size-p + :base-width :base-height :win-gravity)) + (when (getf options arg) (return t))) + (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints)))) + (when x (setf (wm-size-hints-x size) x)) + (when y (setf (wm-size-hints-y size) y)) + (when width (setf (wm-size-hints-width size) width)) + (when height (setf (wm-size-hints-height size) height)) + (when min-width (setf (wm-size-hints-min-width size) min-width)) + (when min-height (setf (wm-size-hints-min-height size) min-height)) + (when max-width (setf (wm-size-hints-max-width size) max-width)) + (when max-height (setf (wm-size-hints-max-height size) max-height)) + (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) + (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) + (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) + (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) + (when base-width (setf (wm-size-hints-base-width size) base-width)) + (when base-height (setf (wm-size-hints-base-height size) base-height)) + (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) + (when user-specified-position-p (setf (wm-size-hints-user-specified-position-p size) + user-specified-position-p)) + (when user-specified-size-p (setf (wm-size-hints-user-specified-size-p size) + user-specified-size-p)) + (setf (wm-normal-hints window) size)) + (when normal-hints (setf (wm-normal-hints window) normal-hints))) + (when zoom-hints (setf (wm-zoom-hints window) zoom-hints)) + ) + +;;; OBSOLETE +(defun set-standard-properties (window &rest options) + (declare (dynamic-extent options)) + (apply #'set-wm-properties window options)) + +;;----------------------------------------------------------------------------- +;; WM Control + +(defun iconify-window (window screen) + (declare (type window window) + (type screen screen)) + (let ((root (screen-root screen))) + (declare (type window root)) + (send-event root :client-message '(:substructure-redirect :substructure-notify) + :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) + +(defun withdraw-window (window screen) + (declare (type window window) + (type screen screen)) + (unmap-window window) + (let ((root (screen-root screen))) + (declare (type window root)) + (send-event root :unmap-notify '(:substructure-redirect :substructure-notify) + :window window :event-window root :configure-p nil))) + + +;;----------------------------------------------------------------------------- +;; Colormaps + +(def-clx-class (standard-colormap (:copier nil) (:predicate nil)) + (colormap nil :type (or null colormap)) + (base-pixel 0 :type pixel) + (max-color nil :type (or null color)) + (mult-color nil :type (or null color)) + (visual nil :type (or null visual-info)) + (kill nil :type (or (member nil :release-by-freeing-colormap) + drawable gcontext cursor colormap font))) + +(defun rgb-colormaps (window property) + (declare (type window window) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) + (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) + (declare (type (or null simple-vector) prop)) + (when prop + (list (make-standard-colormap + :colormap (lookup-colormap (window-display window) (aref prop 0)) + :base-pixel (aref prop 7) + :max-color (make-color :red (card16->rgb-val (aref prop 1)) + :green (card16->rgb-val (aref prop 3)) + :blue (card16->rgb-val (aref prop 5))) + :mult-color (make-color :red (card16->rgb-val (aref prop 2)) + :green (card16->rgb-val (aref prop 4)) + :blue (card16->rgb-val (aref prop 6))) + :visual (and (<= 9 (length prop)) + (visual-info (window-display window) (aref prop 8))) + :kill (and (<= 10 (length prop)) + (let ((killid (aref prop 9))) + (if (= killid 1) + :release-by-freeing-colormap + (lookup-resource-id (window-display window) killid))))))))) + +(defsetf rgb-colormaps set-rgb-colormaps) +(defun set-rgb-colormaps (window property maps) + (declare (type window window) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) property) + (type list maps)) + (let ((prop (make-array (* 10 (length maps)) :element-type 'card32)) + (index -1)) + (dolist (map maps) + (setf (aref prop (incf index)) + (encode-type colormap (standard-colormap-colormap map))) + (setf (aref prop (incf index)) + (encode-type rgb-val (color-red (standard-colormap-max-color map)))) + (setf (aref prop (incf index)) + (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) + (setf (aref prop (incf index)) + (encode-type rgb-val (color-green (standard-colormap-max-color map)))) + (setf (aref prop (incf index)) + (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) + (setf (aref prop (incf index)) + (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) + (setf (aref prop (incf index)) + (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) + (setf (aref prop (incf index)) + (standard-colormap-base-pixel map)) + (setf (aref prop (incf index)) + (visual-info-id (standard-colormap-visual map))) + (setf (aref prop (incf index)) + (let ((kill (standard-colormap-kill map))) + (etypecase kill + (symbol + (ecase kill + ((nil) 0) + ((:release-by-freeing-colormap) 1))) + (drawable (drawable-id kill)) + (gcontext (gcontext-id kill)) + (cursor (cursor-id kill)) + (colormap (colormap-id kill)) + (font (font-id kill)))))) + (change-property window property prop :RGB_COLOR_MAP 32))) + +;;; OBSOLETE +(defun get-standard-colormap (window property) + (declare (type window window) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) + (declare (values colormap base-pixel max-color mult-color)) + (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) + (declare (type (or null simple-vector) prop)) + (when prop + (values (lookup-colormap (window-display window) (aref prop 0)) + (aref prop 7) ;Base Pixel + (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color + :green (card16->rgb-val (aref prop 3)) + :blue (card16->rgb-val (aref prop 5))) + (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color + :green (card16->rgb-val (aref prop 4)) + :blue (card16->rgb-val (aref prop 6))))))) + +;;; OBSOLETE +(defun set-standard-colormap (window property colormap base-pixel max-color mult-color) + (declare (type window window) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) property) + (type colormap colormap) + (type pixel base-pixel) + (type color max-color mult-color)) + (let ((prop (apply #'vector (encode-type colormap colormap) + (encode-type rgb-val (color-red max-color)) + (encode-type rgb-val (color-red mult-color)) + (encode-type rgb-val (color-green max-color)) + (encode-type rgb-val (color-green mult-color)) + (encode-type rgb-val (color-blue max-color)) + (encode-type rgb-val (color-blue mult-color)) + base-pixel))) + (change-property window property prop :RGB_COLOR_MAP 32))) + +;;----------------------------------------------------------------------------- +;; Cut-Buffers + +(defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string) + (transform #'card8->char) (start 0) end) + ;; Return the contents of cut-buffer BUFFER + (declare (type display display) + (type (integer 0 7) buffer) + (type xatom type) + (type array-index start) + (type (or null array-index) end) + (type t result-type) ;a sequence type + (type (or null (function (integer) t)) transform)) + (declare (values sequence type format bytes-after)) + (let* ((root (screen-root (first (display-roots display)))) + (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 + :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) + buffer))) + (get-property root property :type type :result-type result-type + :start start :end end :transform transform))) + +;; Implement the following: +;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8) +;; (transform #'char->card8) (start 0) end) (data) +;; In order to avoid having to pass positional parameters to set-cut-buffer, +;; We've got to do the following. WHAT A PAIN... +(define-setf-method cut-buffer (display &rest option-list) + (declare (dynamic-extent option-list)) + (do* ((options (copy-list option-list)) + (option options (cddr option)) + (store (gensym)) + (dtemp (gensym)) + (temps (list dtemp)) + (values (list display))) + ((endp option) + (values (nreverse temps) + (nreverse values) + (list store) + `(set-cut-buffer ,store ,dtemp ,@options) + `(cut-buffer ,@options))) + (unless (member (car option) '(:buffer :type :format :start :end :transform)) + (error "Keyword arg ~s isn't recognized" (car option))) + (let ((x (gensym))) + (push x temps) + (push (cadr option) values) + (setf (cadr option) x)))) + +(defun set-cut-buffer (data display &key (buffer 0) (type :STRING) (format 8) + (start 0) end (transform #'char->card8)) + (declare (type sequence data) + (type display display) + (type (integer 0 7) buffer) + (type xatom type) + (type (member 8 16 32) format) + (type array-index start) + (type (or null array-index) end) + (type (or null (function (integer) t)) transform)) + (let* ((root (screen-root (first (display-roots display)))) + (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 + :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) + buffer))) + (change-property root property data type format :transform transform :start start :end end) + data)) + +(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t)) + ;; Positive rotates left, negative rotates right (opposite of actual protocol request). + ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors. + (declare (type display display) + (type int16 delta) + (type boolean careful-p)) + (let* ((root (screen-root (first (display-roots display)))) + (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 + :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) + (when careful-p + (let ((props (list-properties root))) + (dotimes (i 8) + (unless (member (aref buffers i) props) + (setf (cut-buffer display :buffer i) ""))))) + (rotate-properties root buffers delta))) + diff --git a/clx/resource.lisp b/clx/resource.lisp new file mode 100644 index 0000000000000000000000000000000000000000..743c14f46aa5c20c059b2a1495da6d7e0d9398a9 --- /dev/null +++ b/clx/resource.lisp @@ -0,0 +1,713 @@ +;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- + +;; RESOURCE - Lisp version of XLIB's Xrm resource manager + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +(export '(resource-database + resource-database-timestamp + make-resource-database + resource-key + get-resource + get-search-table + get-search-resource + add-resource + delete-resource + map-resource + merge-resources + read-resources + write-resources + wm-resources + set-wm-resources + root-resources)) + +#+clue ;; for CLUE only +(defparameter *resource-subclassp* nil + "When non-nil and no match found, search superclasses.") + +;; The C version of this uses a 64 entry hash table at each entry. +;; Small hash tables lose in Lisp, so we do linear searches on lists. + +(defstruct (resource-database (:copier nil) (:predicate nil) + (:print-function print-resource-database) + (:constructor make-resource-database-internal) + #+explorer (:callable-constructors nil) + ) + (name nil :type stringable :read-only t) + (value nil) + (tight nil :type list) ;; List of resource-database + (loose nil :type list) ;; List of resource-database + ) + +(defun print-resource-database (database stream depth) + (declare (type resource-database database) + (ignore depth)) + (print-unreadable-object (database stream :type t) + (princ (resource-database-name database) stream) + (when (resource-database-value database) + (princ " " stream) + (prin1 (resource-database-value database) stream)))) + +;; The value slot of the top-level resource-database structure is used for a +;; time-stamp. + +(defun make-resource-database () + ;; Make a resource-database with initial timestamp of 0 + (make-resource-database-internal :name "Top-Level" :value 0)) + +(defun resource-database-timestamp (database) + (declare (type resource-database database)) + (resource-database-value database)) + +(defun incf-resource-database-timestamp (database) + ;; Increment the timestamp + (declare (type resource-database database)) + (let ((timestamp (resource-database-value database))) + (setf (resource-database-value database) + (if (= timestamp most-positive-fixnum) + most-negative-fixnum + (1+ timestamp))))) + +;; DEBUG FUNCTION (not exported) +(defun print-db (entry &optional (level 0) type) + ;; Debug function to print a resource database + (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]" + level + (resource-database-name entry) + (eq type 'loose) + (resource-database-value entry)) + (when (resource-database-tight entry) + (dolist (tight (resource-database-tight entry)) + (print-db tight (+ 2 level) 'tight))) + (when (resource-database-loose entry) + (dolist (loose (resource-database-loose entry)) + (print-db loose (+ 2 level) 'loose)))) + +;; DEBUG FUNCTION +#+comment +(defun print-search-table (table) + (terpri) + (dolist (dbase-list table) + (format t "~%~s" dbase-list) + (dolist (db dbase-list) + (print-db db) + (dolist (dblist table) + (unless (eq dblist dbase-list) + (when (member db dblist) + (format t " duplicate at ~s" db)))) + ))) + +(defun resource-key (stringable) + ;; Ensure STRINGABLE is a keyword. + (declare (type stringable stringable)) + (if (symbolp stringable) + (if (keywordp (the symbol stringable)) + stringable + (kintern (symbol-name (the symbol stringable)))) + (kintern (#-excl string-upcase + #+excl correct-case + (the string stringable))))) + +(defun stringable-equal (a b) + ;; Compare two stringables. + ;; Ignore case when comparing to a symbol. + (declare (type stringable a b)) + (declare (values boolean)) + (if (symbolp a) + (if (symbolp b) + (string= (the string (symbol-name (the symbol a))) + (the string (symbol-name (the symbol b)))) + (string-equal (the string (symbol-name (the symbol a))) + (the string b))) + (if (symbolp b) + (string-equal (the string a) + (the string (symbol-name (the symbol b)))) + (string= (the string a) + (the string b))))) + + +;;;----------------------------------------------------------------------------- +;;; Add/delete resource + +(defun add-resource (database name-list value) + ;; name-list is a list of either strings or symbols. If a symbol, + ;; case-insensitive comparisons will be used, if a string, + ;; case-sensitive comparisons will be used. The symbol '* or + ;; string "*" are used as wildcards, matching anything or nothing. + (declare (type resource-database database) + (type list name-list) ;; (list stringable) + (type t value)) + (unless value (error "Null resource values are ignored")) + (incf-resource-database-timestamp database) + (do* ((list name-list (cdr list)) + (name (car list) (car list)) + (node database) + (loose-p nil)) + ((endp list) + (setf (resource-database-value node) value)) + ;; Key is the first name that isn't * + (if (stringable-equal name "*") + (setq loose-p t) + ;; find the entry associated with name + (progn + (do ((entry (if loose-p + (resource-database-loose node) + (resource-database-tight node)) + (cdr entry))) + ((endp entry) + ;; Entry not found - create a new one + (setq entry (make-resource-database-internal :name name)) + (if loose-p + (push entry (resource-database-loose node)) + (push entry (resource-database-tight node))) + (setq node entry)) + (when (stringable-equal name (resource-database-name (car entry))) + ;; Found entry - use it + (return (setq node (car entry))))) + (setq loose-p nil))))) + + +(defun delete-resource (database name-list) + (declare (type resource-database database) + (type list name-list)) + (incf-resource-database-timestamp database) + (delete-resource-internal database name-list)) + +(defun delete-resource-internal (database name-list) + (declare (type resource-database database) + (type list name-list)) ;; (list stringable) + (do* ((list name-list (cdr list)) + (string (car list) (car list)) + (node database) + (loose-p nil)) + ((endp list) nil) + ;; Key is the first name that isn't * + (if (stringable-equal string "*") + (setq loose-p t) + ;; find the entry associated with name + (progn + (do* ((first-entry (if loose-p + (resource-database-loose node) + (resource-database-tight node))) + (entry-list first-entry (cdr entry-list)) + (entry (car entry-list) (car entry-list))) + ((endp entry-list) + ;; Entry not found - exit + (return-from delete-resource-internal nil)) + (when (stringable-equal string (resource-database-name entry)) + (when (cdr list) (delete-resource-internal entry (cdr list))) + (when (and (null (resource-database-loose entry)) + (null (resource-database-tight entry))) + (if loose-p + (setf (resource-database-loose node) + (delete entry (resource-database-loose node) + :test #'eq :count 1)) + (setf (resource-database-tight node) + (delete entry (resource-database-tight node) + :test #'eq :count 1)))) + (return-from delete-resource-internal t))) + (setq loose-p nil))))) + +;;;----------------------------------------------------------------------------- +;;; Get Resource + +(defun get-resource (database value-name value-class full-name full-class) + ;; Return the value of the resource in DATABASE whose partial name + ;; most closely matches (append full-name (list value-name)) and + ;; (append full-class (list value-class)). + (declare (type resource-database database) + (type stringable value-name value-class) + (type list full-name full-class)) ;; (list stringable) + (declare (values value)) + (let ((names (append full-name (list value-name))) + (classes (append full-class (list value-class)))) + (let* ((result (get-entry (resource-database-tight database) + (resource-database-loose database) + names classes))) + (when result + (resource-database-value result))))) + +(defun get-entry-lookup (table name names classes) + (declare (type list table names classes) + (symbol name)) + (dolist (entry table) + (declare (type resource-database entry)) + (when (stringable-equal name (resource-database-name entry)) + (if (null (cdr names)) + (return entry) + (let ((result (get-entry (resource-database-tight entry) + (resource-database-loose entry) + (cdr names) (cdr classes)))) + (declare (type (or null resource-database) result)) + (when result + (return result) + )))))) + +(defun get-entry (tight loose names classes &aux result) + (declare (type list tight loose names classes)) + (let ((name (car names)) + (class (car classes))) + (declare (type symbol name class)) + (cond ((and tight + (get-entry-lookup tight name names classes))) + ((and loose + (get-entry-lookup loose name names classes))) + ((and tight + (not (stringable-equal name class)) + (get-entry-lookup tight class names classes))) + ((and loose + (not (stringable-equal name class)) + (get-entry-lookup loose class names classes))) + #+clue ;; for CLUE only + ((and *resource-subclassp* + (or loose tight) + (dolist (class (cluei::class-all-superclasses class)) + (when tight + (when (setq result + (get-entry-lookup tight class names classes)) + (return result))) + (when loose + (when (setq result + (get-entry-lookup loose class names classes)) + (return result)))))) + (loose + (loop + (pop names) (pop classes) + (unless (and names classes) (return nil)) + (setq name (car names) + class (car classes)) + (when (setq result (get-entry-lookup loose name names classes)) + (return result)) + (when (and (not (stringable-equal name class)) + (setq result + (get-entry-lookup loose class names classes))) + (return result)) + #+clue ;; for CLUE only + (when *resource-subclassp* + (dolist (class (cluei::class-all-superclasses class)) + (when (setq result + (get-entry-lookup loose class names classes)) + (return-from get-entry result)))) + ))))) + + +;;;----------------------------------------------------------------------------- +;;; Get-resource with search-table + +(defun get-search-resource (table name class) + ;; (get-search-resource (get-search-table database full-name full-class) + ;; value-name value-class) + ;; is equivalent to + ;; (get-resource database value-name value-class full-name full-class) + ;; But since most of the work is done by get-search-table, + ;; get-search-resource is MUCH faster when getting several resources with + ;; the same full-name/full-class + (declare (type list table) + (type stringable name class)) + (let ((do-class (and class (not (stringable-equal name class))))) + (dolist (dbase-list table) + (declare (type list dbase-list)) + (dolist (dbase dbase-list) + (declare (type resource-database dbase)) + (when (stringable-equal name (resource-database-name dbase)) + (return-from get-search-resource + (resource-database-value dbase)))) + (when do-class + (dolist (dbase dbase-list) + (declare (type resource-database dbase)) + (when (stringable-equal class (resource-database-name dbase)) + (return-from get-search-resource + (resource-database-value dbase)))))))) + +(defvar *get-table-result*) + +(defun get-search-table (database full-name full-class) + ;; Return a search table for use with get-search-resource. + (declare (type resource-database database) + (type list full-name full-class)) ;; (list stringable) + (declare (values value)) + (let* ((tight (resource-database-tight database)) + (loose (resource-database-loose database)) + (result (cons nil nil)) + (*get-table-result* result)) + (declare (type list tight loose) + (type cons result)) + (when (or tight loose) + (when full-name + (get-tables tight loose full-name full-class)) + + ;; Pick up bindings of the form (* name). These are the elements of + ;; top-level loose without further tight/loose databases. + ;; + ;; (Hack: these bindings belong in ANY search table, so recomputing them + ;; is a drag. True fix involves redesigning entire lookup + ;; data-structure/algorithm.) + ;; + (let ((universal-bindings + (remove nil loose :test-not #'eq + :key #'(lambda (database) + (or (resource-database-tight database) + (resource-database-loose database)))))) + (when universal-bindings + (setf (cdr *get-table-result*) (list universal-bindings))))) + (cdr result))) + +(defun get-tables-lookup (dbase name names classes) + (declare (type list dbase names classes) + (type symbol name)) + (declare (optimize speed)) + (dolist (entry dbase) + (declare (type resource-database entry)) + (when (stringable-equal name (resource-database-name entry)) + (let ((tight (resource-database-tight entry)) + (loose (resource-database-loose entry))) + (declare (type list tight loose)) + (when (or tight loose) + (if (cdr names) + (get-tables tight loose (cdr names) (cdr classes)) + (when tight + (let ((result *get-table-result*)) + ;; Put tight at end of *get-table-result* + (setf (cdr result) + (setq *get-table-result* (cons tight nil)))))) + (when loose + (let ((result *get-table-result*)) + ;; Put loose at end of *get-table-result* + (setf (cdr result) + (setq *get-table-result* (cons loose nil)))))))))) + +(defun get-tables (tight loose names classes) + (declare (type list tight loose names classes)) + (let ((name (car names)) + (class (car classes))) + (declare (type symbol name class)) + (when tight + (get-tables-lookup tight name names classes)) + (when loose + (get-tables-lookup loose name names classes)) + (when (and tight (not (stringable-equal name class))) + (get-tables-lookup tight class names classes)) + (when (and loose (not (stringable-equal name class))) + (get-tables-lookup loose class names classes)) + #+clue ;; for CLUE only + (when *resource-subclassp* + (dolist (class (cluei::class-all-superclasses class)) + (declare (type symbol class)) + (setq class class) + (when tight + (get-tables-lookup tight class names classes)) + (when loose + (get-tables-lookup loose class names classes)))) + (when loose + (loop + (pop names) (pop classes) + (unless (and names classes) (return nil)) + (setq name (car names) + class (car classes)) + (get-tables-lookup loose name names classes) + (unless (stringable-equal name class) + (get-tables-lookup loose class names classes)) + #+clue ;; for CLUE only + (when *resource-subclassp* + (dolist (class (cluei::class-all-superclasses class)) + (get-tables-lookup loose class names classes))) + )))) + + +;;;----------------------------------------------------------------------------- +;;; Utility functions + +(defun map-resource (database function &rest args) + ;; Call FUNCTION on each resource in DATABASE. + ;; FUNCTION is called with arguments (name-list value . args) + (declare (type resource-database database) + (type (function (list t &rest t) t) function) + (downward-funarg function) + (dynamic-extent args)) + (declare (values nil)) + (labels ((map-resource-internal (database function args name) + (declare (type resource-database database) + (type (function (list t &rest t) t) function) + (type list name) + (downward-funarg function)) + (let ((tight (resource-database-tight database)) + (loose (resource-database-loose database))) + (declare (type list tight loose)) + (dolist (resource tight) + (declare (type resource-database resource)) + (let ((value (resource-database-value resource)) + (name (append + name + (list (resource-database-name resource))))) + (if value + (apply function name value args) + (map-resource-internal resource function args name)))) + (dolist (resource loose) + (declare (type resource-database resource)) + (let ((value (resource-database-value resource)) + (name (append + name + (list "*" (resource-database-name resource))))) + (if value + (apply function name value args) + (map-resource-internal resource function args name))))))) + (map-resource-internal database function args nil))) + +(defun merge-resources (database with-database) + (declare (type resource-database database with-database)) + (declare (values resource-database)) + (map-resource #'add-resource database with-database) + with-database) + +(defun char-memq (key char) + ;; Used as a test function for POSITION + (declare (type string-char char)) + (member char key)) + +(defmacro resource-with-open-file ((stream pathname &rest options) &body body) + ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the + ;; stream + (let ((abortp (gensym)) + (streamp (gensym))) + `(let* ((,abortp t) + (,streamp (streamp pathname)) + (,stream (if ,streamp pathname (open ,pathname ,@options)))) + (unwind-protect + (progn + ,@body + (setq ,abortp nil)) + (unless ,streamp + (close stream :abort ,abortp)))))) + +(defun read-resources (database pathname &key key test test-not) + ;; Merges resources from a file in standard X11 format with DATABASE. + ;; KEY is a function used for converting value-strings, the default is + ;; identity. TEST and TEST-NOT are predicates used for filtering + ;; which resources to include in the database. They are called with + ;; the name and results of the KEY function. + (declare (type resource-database database) + (type (or pathname string stream) pathname) + (type (or null (function (string) t)) key) + (type (or null (function (list t) boolean)) + test test-not)) + (declare (values resource-database)) + (resource-with-open-file (stream pathname) + (loop + (let ((string (read-line stream nil :eof))) + (declare (type string string)) + (when (eq string :eof) (return database)) + (let* ((end (length string)) + (i (position '(#\tab #\space) string + :test-not #'char-memq :end end)) + (term nil)) + (declare (type array-index end) + (type (or null array-index) i term)) + (when i ;; else blank line + (case (char string i) + (#\! nil) ;; Comment - skip + (#.(card8->char 0) nil) ;; terminator for C strings - skip + (#\# ;; Include + (setq term (position '(#\tab #\space) string :test #'char-memq + :start i :end end)) + (if (not (string-equal string "#INCLUDE" :start1 i :end1 term)) + (format t "~%Resource File error. Ignoring: ~a" string) + (let ((path (merge-pathnames + (subseq string (1+ term)) (truename stream)))) + (read-resources database path + :key key :test test :test-not test-not)))) + (otherwise + (multiple-value-bind (name-list value) + (parse-resource string i end) + (when key (setq value (funcall key value))) + (when + (cond (test (funcall test name-list value)) + (test-not (not (funcall test-not name-list value))) + (t t)) + (add-resource database name-list value))))))))))) + +(defun parse-resource (string &optional (start 0) end) + ;; Parse a resource specfication string into a list of names and a value + ;; string + (declare (type string string) + (type array-index start) + (type (or null array-index) end)) + (declare (values name-list value)) + (do ((i start) + (end (or end (length string))) + (term) + (name-list)) + ((>= i end)) + (declare (type array-index end) + (type (or null array-index) i term)) + (setq term (position '(#\. #\* #\:) string + :test #'char-memq :start i :end end)) + (case (and term (char string term)) + ;; Name seperator + (#\. (when (> term i) + (push (subseq string i term) name-list))) + ;; Wildcard seperator + (#\* (when (> term i) + (push (subseq string i term) name-list)) + (push '* name-list)) + ;; Value separator + (#\: + (push (subseq string i term) name-list) + (return + (values + (nreverse name-list) + (string-trim '(#\tab #\space) (subseq string (1+ term))))))) + (setq i (1+ term)))) + +(defun write-resources (database pathname &key write test test-not) + ;; Write resources to PATHNAME in the standard X11 format. + ;; WRITE is a function used for writing values, the default is #'princ + ;; TEST and TEST-NOT are predicates used for filtering which resources + ;; to include in the database. They are called with the name and value. + (declare (type resource-database database) + (type (or pathname string stream) pathname) + (type (or null (function (string stream) t)) write) + (type (or null (function (list t) boolean)) + test test-not)) + (resource-with-open-file (stream pathname :direction :output) + (map-resource + database + #'(lambda (name-list value stream write test test-not) + (when + (cond (test (funcall test name-list value)) + (test-not (not (funcall test-not name-list value))) + (t t)) + (let ((previous (car name-list))) + (princ previous stream) + (dolist (name (cdr name-list)) + (unless (or (stringable-equal name "*") + (stringable-equal previous "*")) + (write-char #\. stream)) + (setq previous name) + (princ name stream))) + (write-string ": " stream) + (funcall write value stream) + (terpri stream))) + stream (or write #'princ) test test-not)) + database) + +(defun wm-resources (database window &key key test test-not) + ;; Takes the resources associated with the RESOURCE_MANAGER property + ;; of WINDOW (if any) and merges them with DATABASE. + ;; KEY is a function used for converting value-strings, the default is + ;; identity. TEST and TEST-NOT are predicates used for filtering + ;; which resources to include in the database. They are called with + ;; the name and results of the KEY function. + (declare (type resource-database database) + (type window window) + (type (or null (function (string) t)) key) + (type (or null (function (list t) boolean)) + test test-not)) + (declare (values resource-database)) + (let ((string (get-property window :RESOURCE_MANAGER :type :STRING + :result-type 'string + :transform #'xlib::card8->char))) + (when string + (with-input-from-string (stream string) + (read-resources database stream + :key key :test test :test-not test-not))))) + +(defun set-wm-resources (database window &key write test test-not) + ;; Sets the resources associated with the RESOURCE_MANAGER property + ;; of WINDOW. + ;; WRITE is a function used for writing values, the default is #'princ + ;; TEST and TEST-NOT are predicates used for filtering which resources + ;; to include in the database. They are called with the name and value. + (declare (type resource-database database) + (type window window) + (type (or null (function (string stream) t)) write) + (type (or null (function (list t) boolean)) + test test-not)) + (xlib::set-string-property + window :RESOURCE_MANAGER + (with-output-to-string (stream) + (write-resources database stream :write write + :test test :test-not test-not)))) + +(defun root-resources (screen &key database key test test-not) + "Returns a resource database containing the contents of the root window + RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, + then its default screen is used. If an existing DATABASE is given, then + resource values are merged with the DATABASE and the modified DATABASE is + returned. + + TEST and TEST-NOT are predicates for selecting which resources are + read. Arguments are a resource name list and a resource value. The KEY + function, if given, is called to convert a resource value string to the + value given to TEST or TEST-NOT." + + (declare (type (or screen display) screen) + (type (or null resource-database) database) + (type (or null (function (string) t)) key) + (type (or null (function (list t) boolean)) test test-not) + (values resource-database)) + (let* ((screen (if (type? screen 'display) + (display-default-screen screen) + screen)) + (window (screen-root screen)) + (database (or database (make-resource-database)))) + (wm-resources database window :key key :test test :test-not test-not) + database)) + +(defun set-root-resources (screen &key test test-not (write 'princ) database) + "Changes the contents of the root window RESOURCE_MANAGER property for the + given SCREEN. If SCREEN is a display, then its default screen is used. + + TEST and TEST-NOT are predicates for selecting which resources from the + DATABASE are written. Arguments are a resource name list and a resource + value. The WRITE function is used to convert a resource value into a + string stored in the property." + + (declare (type (or screen display) screen) + (type (or null resource-database) database) + (type (or null (function (list t) boolean)) test test-not) + (type (or null (function (string stream) t)) write) + (values resource-database)) + (let* ((screen (if (type? screen 'display) + (display-default-screen screen) + screen)) + (window (screen-root screen))) + (set-wm-resources database window + :write write :test test :test-not test-not) + database)) + +(defsetf root-resources set-root-resources) + +(defun initialize-resource-database (display) + ;; This function is (supposed to be) equivalent to the Xlib initialization + ;; code. + (declare (type display display)) + (let ((rdb (make-resource-database)) + (rootwin (screen-root (car (display-roots display))))) + ;; First read the server defaults if present, otherwise from the default + ;; resource file + (if (get-property rootwin :RESOURCE_MANAGER) + (xlib:wm-resources rdb rootwin) + (let ((path (default-resources-pathname))) + (when (and path (probe-file path)) + (read-resources rdb path)))) + ;; Next read from the resources file + (let ((path (resources-pathname))) + (when (and path (probe-file path)) + (read-resources rdb path))) + (setf (display-xdefaults display) rdb))) diff --git a/clx/text.lisp b/clx/text.lisp new file mode 100644 index 0000000000000000000000000000000000000000..59415101c25ec69c862d076d8662653e2aec0417 --- /dev/null +++ b/clx/text.lisp @@ -0,0 +1,1083 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- + +;;; CLX text keyboard and pointer requests + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +(export '( + translation-function + translate-default + text-extents + text-width + draw-glyph + draw-glyphs + draw-image-glyph + draw-image-glyphs + display-keycode-range + set-modifier-mapping + modifier-mapping + keysym + change-keyboard-mapping + keyboard-mapping + keyboard-mapping + )) + +;; Strings are broken up into chunks of this size +(defparameter *max-string-size* 254) + +;; In the functions below, the transform is used to convert an element of the +;; sequence into a font index. The transform is applied to each element of the +;; (sub)sequence, until either the transform returns nil or the end of the +;; (sub)sequence is reached. If transform returns nil for an element, the +;; index of that element in the sequence is returned, otherwise nil is +;; returned. + +(deftype translation-function () + #+explorer t + #-explorer + '(function (sequence array-index array-index (or null font) vector array-index) + (values array-index (or null int16 font) (or null int32)))) + +;; In the functions below, if width is specified, it is assumed to be the pixel +;; width of whatever string of glyphs is actually drawn. Specifying width will +;; allow for appending the output of subsequent calls to the same protocol +;; request, provided gcontext has not been modified in the interim. If width +;; is not specified, appending of subsequent output might not occur. +;; Specifying width is simply a hint, for performance. Note that specifying +;; width may be difficult if transform can return nil. + +(defun translate-default (src src-start src-end font dst dst-start) + ;; dst is guaranteed to have room for (- src-end src-start) integer elements, + ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends + ;; on context. font is the current font, if known. The function should + ;; translate as many elements of src as possible into indexes in the current + ;; font, and store them into dst. + ;; + ;; The first return value should be the src index of the first untranslated + ;; element. If no further elements need to be translated, the second return + ;; value should be nil. If a horizontal motion is required before further + ;; translation, the second return value should be the delta in x coordinate. + ;; If a font change is required for further translation, the second return + ;; value should be the new font. If known, the pixel width of the translated + ;; text can be returned as the third value; this can allow for appending of + ;; subsequent output to the same protocol request, if no overall width has + ;; been specified at the higher level. + ;; (returns values: ending-index + ;; (OR null horizontal-motion font) + ;; (OR null translated-width)) + (declare (type sequence src) + (type array-index src-start src-end dst-start) + (type (or null font) font) + (type vector dst) + (inline graphic-char-p)) + (declare (values integer (or null integer font) (or null integer))) + font ;;not used + (if (stringp src) + (do ((i src-start (index+ i 1)) + (j dst-start (index+ j 1)) + (char)) + ((index>= i src-end) + i) + (declare (type array-index i j)) + (if (graphic-char-p (setq char (char src i))) + (setf (aref dst j) (char->card8 char)) + (return i))) + (do ((i src-start (index+ i 1)) + (j dst-start (index+ j 1)) + (elt)) + ((index>= i src-end) + i) + (declare (type array-index i j)) + (setq elt (elt src i)) + (cond ((and (characterp elt) (graphic-char-p elt)) + (setf (aref dst j) (char->card8 elt))) + ((integerp elt) + (setf (aref dst j) elt)) + (t + (return i)))))) + +;; There is a question below of whether translate should always be required, or +;; if not, what the default should be or where it should come from. For +;; example, the default could be something that expected a string as src and +;; translated the CL standard character set to ASCII indexes, and ignored fonts +;; and bits. Or the default could expect a string but otherwise be "system +;; dependent". Or the default could be something that expected a vector of +;; integers and did no translation. Or the default could come from the +;; gcontext (but what about text-extents and text-width?). + +(defun text-extents (font sequence &key (start 0) end translate) + ;; If multiple fonts are involved, font-ascent and font-descent will be the + ;; maximums. If multiple directions are involved, the direction will be nil. + ;; Translate will always be called with a 16-bit dst buffer. + (declare (type sequence sequence) + (type (or font gcontext) font)) + (declare (type (or null translation-function) translate) + (downward-funarg #+Genera * #-Genera translate)) + (declare (values width ascent descent left right + font-ascent font-descent direction + (or null array-index))) + (when (type? font 'gcontext) + (force-gcontext-changes font) + (setq font (gcontext-font font t))) + (check-type font font) + (let* ((left-bearing 0) + (right-bearing 0) + ;; Sum of widths + (width 0) + (ascent 0) + (descent 0) + (overall-ascent (font-ascent font)) + (overall-descent (font-descent font)) + (overall-direction (font-direction font)) + (next-start nil) + (display (font-display font))) + (declare (type int16 ascent descent overall-ascent overall-descent) + (type int32 left-bearing right-bearing width) + (type (or null array-index) next-start) + (type display display)) + (with-display (display) + (do* ((wbuf (display-tbuf16 display)) + (src-end (or end (length sequence))) + (src-start start end) + (end (index-min src-end (index+ src-start *buffer-text16-size*)) + (index-min src-end (index+ src-start *buffer-text16-size*))) + (buf-end 0) + (new-font) + (font-ascent 0) + (font-descent 0) + (font-direction) + (stop-p nil)) + ((or stop-p (index>= src-start src-end)) + (when (index< src-start src-end) + (setq next-start src-start))) + (declare (type buffer-text16 wbuf) + (type array-index src-start src-end end buf-end) + (type int16 font-ascent font-descent) + (type boolean stop-p)) + ;; Translate the text + (multiple-value-setq (buf-end new-font) + (funcall (or translate #'translate-default) + sequence src-start end font wbuf 0)) + (setq buf-end (- buf-end src-start)) + (cond ((null new-font) (setq stop-p t)) + ((integerp new-font) (incf width (the int32 new-font))) + ((type? new-font 'font) (setq font new-font))) + + (let (w a d l r) + (if (or (font-char-infos-internal font) (font-local-only-p font)) + ;; Calculate text extents locally + (progn + (multiple-value-setq (w a d l r) + (text-extents-local font wbuf 0 buf-end nil)) + (setq font-ascent (the int16 (font-ascent font)) + font-descent (the int16 (font-descent font)) + font-direction (font-direction font))) + ;; Let the server calculate text extents + (multiple-value-setq + (w a d l r font-ascent font-descent font-direction) + (text-extents-server font wbuf 0 buf-end))) + (incf width (the int32 w)) + (cond ((index= src-start start) + (setq left-bearing (the int32 l)) + (setq right-bearing (the int32 r)) + (setq ascent (the int16 a)) + (setq descent (the int16 d))) + (t + (setq left-bearing (the int32 (min left-bearing (the int32 l)))) + (setq right-bearing (the int32 (max right-bearing (the int32 r)))) + (setq ascent (the int16 (max ascent (the int16 a)))) + (setq descent (the int16 (max descent (the int16 d))))))) + + (setq overall-ascent (the int16 (max overall-ascent font-ascent))) + (setq overall-descent (the int16 (max overall-descent font-descent))) + (case overall-direction + (:unknown (setq overall-direction font-direction)) + (:left-to-right (unless (eq font-direction :left-to-right) + (setq overall-direction nil))) + (:right-to-left (unless (eq font-direction :right-to-left) + (setq overall-direction nil)))))) + + (values width + ascent + descent + left-bearing + right-bearing + overall-ascent + overall-descent + overall-direction + next-start))) + +(defun text-width (font sequence &key (start 0) end translate) + ;; Translate will always be called with a 16-bit dst buffer. + (declare (type sequence sequence) + (type (or font gcontext) font) + (type array-index start) + (type (or null array-index) end)) + (declare (type (or null translation-function) translate) + (downward-funarg #+Genera * #-Genera translate)) + (declare (values integer (or null integer))) + (when (type? font 'gcontext) + (force-gcontext-changes font) + (setq font (gcontext-font font t))) + (check-type font font) + (let* ((width 0) + (next-start nil) + (display (font-display font))) + (declare (type int32 width) + (type (or null array-index) next-start) + (type display display)) + (with-display (display) + (do* ((wbuf (display-tbuf16 display)) + (src-end (or end (length sequence))) + (src-start start end) + (end (index-min src-end (index+ src-start *buffer-text16-size*)) + (index-min src-end (index+ src-start *buffer-text16-size*))) + (buf-end 0) + (new-font) + (stop-p nil)) + ((or stop-p (index>= src-start src-end)) + (when (index< src-start src-end) + (setq next-start src-start))) + (declare (type buffer-text16 wbuf) + (type array-index src-start src-end end buf-end) + (type boolean stop-p)) + ;; Translate the text + (multiple-value-setq (buf-end new-font) + (funcall (or translate #'translate-default) + sequence src-start end font wbuf 0)) + (setq buf-end (- buf-end src-start)) + (cond ((null new-font) (setq stop-p t)) + ((integerp new-font) (incf width (the int32 new-font))) + ((type? new-font 'font) (setq font new-font))) + + (incf width + (if (or (font-char-infos-internal font) (font-local-only-p font)) + (text-extents-local font wbuf 0 buf-end :width-only) + (text-width-server font wbuf 0 buf-end))))) + (values width next-start))) + +#+clx-little-endian +(defun byte-swap-card16 (card16) + (declare (type card16 card16)) + (declare (values card16)) + (dpb card16 (byte 8 8) (ash card16 -8))) + +(defun text-extents-server (font string start end) + (declare (type font font) + (type string string) + (type array-index start end)) + (declare (values width ascent descent left right font-ascent font-descent direction)) + (let ((display (font-display font)) + (length (index- end start)) + (font-id (font-id font))) + (declare (type display display) + (type array-index length) + (type resource-id font-id)) + (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes (8 16 32)) + (((data boolean) (oddp length)) + (length (index+ (index-ceiling length 2) 2)) + (resource-id font-id) + ((sequence :format card16 :start start :end end :appending t + #+clx-little-endian :transform + #+clx-little-endian ;; Byte swap for little-endian + #'byte-swap-card16) + string)) + (values + (integer-get 16) + (int16-get 12) + (int16-get 14) + (integer-get 20) + (integer-get 24) + (int16-get 8) + (int16-get 10) + (member8-get 1 :left-to-right :right-to-left))))) + +(defun text-width-server (font string start end) + (declare (type (or font gcontext) font) + (type string string) + (type array-index start end)) + (declare (values integer)) + (let ((display (font-display font)) + (length (index- end start)) + (font-id (font-id font))) + (declare (type display display) + (type array-index length) + (type resource-id font-id)) + (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes 32) + (((data boolean) (oddp length)) + (length (index+ (index-ceiling length 2) 2)) + (resource-id font-id) + ((sequence :format card16 :start start :end end :appending t + #+clx-little-endian :transform + #+clx-little-endian ;; Byte swap for little-endian + #'byte-swap-card16) + string)) + (values (integer-get 16))))) + +(defun text-extents-local (font sequence start end width-only-p) + (declare (type font font) + (type sequence sequence) + (type integer start end) + (type boolean width-only-p)) + (declare (values width ascent descent overall-left overall-right)) + (let* ((char-infos (font-char-infos font)) + (font-info (font-font-info font))) + (declare (type font-info font-info)) + (declare (type (simple-array int16 (*)) char-infos) + (array-register char-infos)) + (if (zerop (length char-infos)) + ;; Fixed width font + (let* ((font-width (max-char-width font)) + (font-ascent (max-char-ascent font)) + (font-descent (max-char-descent font)) + (width (* (index- end start) font-width))) + (declare (type int16 font-width font-ascent font-descent) + (type int32 width)) + (if width-only-p + width + (values width + font-ascent + font-descent + (max-char-left-bearing font) + (+ width (- font-width) (max-char-right-bearing font))))) + + ;; Variable-width font + (let* ((first-col (font-info-min-byte2 font-info)) + (num-cols (1+ (- (font-info-max-byte2 font-info) first-col))) + (first-row (font-info-min-byte1 font-info)) + (last-row (font-info-max-byte1 font-info)) + (num-rows (1+ (- last-row first-row)))) + (declare (type card8 first-col first-row last-row) + (type card16 num-cols num-rows)) + (if (or (plusp first-row) (plusp last-row)) + + ;; Matrix (16 bit) font + (macrolet ((char-info-elt (sequence elt) + `(let* ((char (the card16 (elt ,sequence ,elt))) + (row (- (ash char -8) first-row)) + (col (- (logand char #xff) first-col))) + (declare (type card16 char) + (type int16 row col)) + (if (and (< -1 row num-rows) (< -1 col num-cols)) + (index* 6 (index+ (index* row num-cols) col)) + -1)))) + (if width-only-p + (do ((i start (index1+ i)) + (width 0)) + ((index>= i end) width) + (declare (type array-index i) + (type int32 width)) + (let ((n (char-info-elt sequence i))) + (declare (type fixnum n)) + (unless (minusp n) ;; Ignore characters not in the font + (incf width (the int16 (aref char-infos (index+ 2 n))))))) + ;; extents + (do ((i start (index1+ i)) + (width 0) + (ascent 0) + (descent 0) + (left #x7fff) + (right 0)) + ((index>= i end) + (values width ascent descent left right)) + (declare (type array-index i) + (type int16 ascent descent) + (type int32 width left right)) + (let ((n (char-info-elt sequence i))) + (declare (type fixnum n)) + (unless (minusp n) ;; Ignore characters not in the font + (setq left (min left (+ width (aref char-infos n)))) + (setq right (max right (+ width (aref char-infos (index1+ n))))) + (incf width (aref char-infos (index+ 2 n))) + (setq ascent (max ascent (aref char-infos (index+ 3 n)))) + (setq descent (max descent (aref char-infos (index+ 4 n))))))))) + + ;; Non-matrix (8 bit) font + ;; The code here is identical to the above, except for the following macro: + (macrolet ((char-info-elt (sequence elt) + `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col))) + (declare (type int16 col)) + (if (< -1 col num-cols) + (index* 6 col) + -1)))) + (if width-only-p + (do ((i start (index1+ i)) + (width 0)) + ((index>= i end) width) + (declare (type array-index i) + (type int32 width)) + (let ((n (char-info-elt sequence i))) + (declare (type fixnum n)) + (unless (minusp n) ;; Ignore characters not in the font + (incf width (the int16 (aref char-infos (index+ 2 n))))))) + ;; extents + (do ((i start (index1+ i)) + (width 0) + (ascent 0) + (descent 0) + (left #x7fff) + (right 0)) + ((index>= i end) + (values width ascent descent left right)) + (declare (type array-index i) + (type int16 ascent descent) + (type int32 width left right)) + (let ((n (char-info-elt sequence i))) + (declare (type fixnum n)) + (unless (minusp n) ;; Ignore characters not in the font + (setq left (min left (+ width (aref char-infos n)))) + (setq right (max right (+ width (aref char-infos (index1+ n))))) + (incf width (aref char-infos (index+ 2 n))) + (setq ascent (max ascent (aref char-infos (index+ 3 n)))) + (setq descent (max descent (aref char-infos (index+ 4 n))))) + )))) + ))))) + +;;----------------------------------------------------------------------------- + +;; This controls the element size of the dst buffer given to translate. If +;; :default is specified, the size will be based on the current font, if known, +;; and otherwise 16 will be used. [An alternative would be to pass the buffer +;; size to translate, and allow it to return the desired size if it doesn't +;; like the current size. The problem is that the protocol doesn't allow +;; switching within a single request, so to allow switching would require +;; knowing the width of text, which isn't necessarily known. We could call +;; text-width to compute it, but perhaps that is doing too many favors?] [An +;; additional possibility is to allow an index-size of :two-byte, in which case +;; translate would be given a double-length 8-bit array, and translate would be +;; expected to store first-byte/second-byte instead of 16-bit integers.] + +(deftype index-size () '(member :default 8 16)) + +;; In the functions below, if width is specified, it is assumed to be the total +;; pixel width of whatever string of glyphs is actually drawn. Specifying +;; width will allow for appending the output of subsequent calls to the same +;; protocol request, provided gcontext has not been modified in the interim. +;; If width is not specified, appending of subsequent output might not occur +;; (unless translate returns the width). Specifying width is simply a hint, +;; for performance. + +(defun draw-glyph (drawable gcontext x y elt + &key translate width (size :default)) + ;; Returns true if elt is output, nil if translate refuses to output it. + ;; Second result is width, if known. + (declare (type drawable drawable) + (type gcontext gcontext) + (type int16 x y) + (type (or null int32) width) + (type index-size size)) + (declare (type (or null translation-function) translate) + (downward-funarg #+Genera * #-Genera translate)) + (declare (values boolean (or null int32))) + (let* ((display (gcontext-display gcontext)) + (result t) + (opcode *x-polytext8*)) + (declare (type display display)) + (let ((vector (allocate-gcontext-state))) + (declare (type gcontext-state vector)) + (setf (aref vector 0) elt) + (multiple-value-bind (new-start new-font translate-width) + (funcall (or translate #'translate-default) + vector 0 1 (gcontext-font gcontext t) vector 1) + ;; Allow translate to set a new font + (when (type? new-font 'font) + (setf (gcontext-font gcontext) new-font) + (multiple-value-setq (new-start new-font translate-width) + (funcall translate vector 0 1 new-font vector 1))) + ;; If new-start is zero, translate refuses to output it + (setq result (index-plusp new-start) + elt (aref vector 1)) + (deallocate-gcontext-state vector) + (when translate-width (setq width translate-width)))) + (when result + (when (eql size 16) + (setq opcode *x-polytext16*) + (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) + (with-buffer-request (display opcode :gc-force gcontext) + (drawable drawable) + (gcontext gcontext) + (int16 x y) + (card8 1 0) + (card8 (ldb (byte 8 0) elt)) + (card8 (ldb (byte 8 8) elt))) + (values t width)))) + +(defun draw-glyphs (drawable gcontext x y sequence + &key (start 0) end translate width (size :default)) + ;; First result is new start, if end was not reached. Second result is + ;; overall width, if known. + (declare (type drawable drawable) + (type gcontext gcontext) + (type int16 x y) + (type array-index start) + (type sequence sequence) + (type (or null array-index) end) + (type (or null int32) width) + (type index-size size)) + (declare (type (or null translation-function) translate) + (downward-funarg #+Genera * #-Genera translate)) + (declare (values (or null array-index) (or null int32))) + (unless end (setq end (length sequence))) + (ecase size + ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end + (or translate #'translate-default) width)) + (16 (draw-glyphs16 drawable gcontext x y sequence start end + (or translate #'translate-default) width)))) + +(defun draw-glyphs8 (drawable gcontext x y sequence start end translate width) + ;; First result is new start, if end was not reached. Second result is + ;; overall width, if known. + (declare (type drawable drawable) + (type gcontext gcontext) + (type int32 x y width) + (type array-index start end) + (type sequence sequence)) + (declare (values (or null array-index) (or null int32))) + (declare (type translation-function translate) + (downward-funarg translate)) + (let* ((src-start start) + (src-end (or end (length sequence))) + (next-start nil) + (length (index- src-end src-start)) + (request-length (* length 2)) ; Leave lots of room for font shifts. + (display (gcontext-display gcontext)) + ;; Should metrics-p be T? Don't want to pass a NIL font into translate... + (font (gcontext-font gcontext t))) + (declare (type array-index src-start src-end length) + (type (or null array-index) next-start) + (type display display)) + (with-buffer-request (display *x-polytext8* :gc-force gcontext :length request-length) + (drawable drawable) + (gcontext gcontext) + (int16 x y) + (progn + ;; Don't let any flushes happen since we manually set the request + ;; length when we're done. + (with-buffer-flush-inhibited (display) + (do* ((boffset (index+ buffer-boffset 16)) + (src-chunk 0) + (dst-chunk 0) + (offset 0) + (overall-width 0) + (stop-p nil)) + ((or stop-p (zerop length)) + ;; Ensure terminated with zero bytes + (do ((end (the array-index (lround boffset)))) + ((index>= boffset end)) + (setf (aref buffer-bbuf boffset) 0) + (index-incf boffset)) + (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) + (setf (buffer-boffset display) boffset) + (unless (index-zerop length) (setq next-start src-start)) + (when overall-width (setq width overall-width))) + + (declare (type array-index src-chunk dst-chunk offset) + (type (or null int32) overall-width) + (type boolean stop-p)) + (setq src-chunk (index-min length *max-string-size*)) + (multiple-value-bind (new-start new-font translated-width) + (funcall translate + sequence src-start (index+ src-start src-chunk) + font buffer-bbuf (index+ boffset 2)) + (setq dst-chunk (index- new-start src-start) + length (index- length dst-chunk) + src-start new-start) + (if translated-width + (when overall-width (incf overall-width translated-width)) + (setq overall-width nil)) + (when (index-plusp dst-chunk) + (setf (aref buffer-bbuf boffset) dst-chunk) + (setf (aref buffer-bbuf (index+ boffset 1)) offset) + (incf boffset (index+ dst-chunk 2))) + (setq offset 0) + (cond ((null new-font) + ;; Don't stop if translate copied whole chunk + (unless (index= src-chunk dst-chunk) + (setq stop-p t))) + ((integerp new-font) (setq offset new-font)) + ((type? new-font 'font) + (setq font new-font) + (let ((font-id (font-id font)) + (buffer-boffset boffset)) + (declare (type resource-id font-id) + (type array-index buffer-boffset)) + ;; This changes the gcontext font in the server + ;; Update the gcontext cache (both local and server state) + (let ((local-state (gcontext-local-state gcontext)) + (server-state (gcontext-server-state gcontext))) + (declare (type gcontext-state local-state server-state)) + (setf (gcontext-internal-font-obj server-state) font + (gcontext-internal-font server-state) font-id) + (without-interrupts + (setf (gcontext-internal-font-obj local-state) font + (gcontext-internal-font local-state) font-id))) + (card8-put 0 #xff) + (card8-put 1 (ldb (byte 8 24) font-id)) + (card8-put 2 (ldb (byte 8 16) font-id)) + (card8-put 3 (ldb (byte 8 8) font-id)) + (card8-put 4 (ldb (byte 8 0) font-id))) + (index-incf boffset 5))) + ))))) + (values next-start width))) + +;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer +;; on 16bit boundaries and this function garbles the bytes. +(defun draw-glyphs16 (drawable gcontext x y sequence start end translate width) + ;; First result is new start, if end was not reached. Second result is + ;; overall width, if known. + (declare (type drawable drawable) + (type gcontext gcontext) + (type int16 x y) + (type array-index start end) + (type int32 width) + (type sequence sequence)) + (declare (values (or null array-index) (or null int32))) + (declare (type translation-function translate) + (downward-funarg translate)) + (let* ((src-start start) + (src-end (or end (length sequence))) + (next-start nil) + (length (index- src-end src-start)) + (request-length (* length 3)) ; Leave lots of room for font shifts. + (display (gcontext-display gcontext)) + ;; Should metrics-p be T? Don't want to pass a NIL font into translate... + (font (gcontext-font gcontext t)) + (buffer (display-tbuf16 display))) + (declare (type array-index src-start src-end length) + (type (or null array-index) next-start) + (type display display) + (type buffer-text16 buffer)) + (with-buffer-request (display *x-polytext16* :gc-force gcontext :length request-length) + (drawable drawable) + (gcontext gcontext) + (int16 x y) + (progn + ;; Don't let any flushes happen since we manually set the request + ;; length when we're done. + (with-buffer-flush-inhibited (display) + (do* ((boffset (index+ buffer-boffset 16)) + (src-chunk 0) + (dst-chunk 0) + (offset 0) + (overall-width 0) + (stop-p nil)) + ((or stop-p (zerop length)) + ;; Ensure terminated with zero bytes + (do ((end (lround boffset))) + ((index>= boffset end)) + (setf (aref buffer-bbuf boffset) 0) + (index-incf boffset)) + (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) + (setf (buffer-boffset display) boffset) + (unless (zerop length) (setq next-start src-start)) + (when overall-width (setq width overall-width))) + + (declare (type array-index boffset src-chunk dst-chunk offset) + (type (or null int32) overall-width) + (type boolean stop-p)) + (setq src-chunk (index-min length *max-string-size*)) + (multiple-value-bind (new-start new-font translated-width) + (funcall translate + sequence src-start (index+ src-start src-chunk) + font buffer 0) + (setq dst-chunk (index- new-start src-start) + length (index- length dst-chunk) + src-start new-start) + (write-sequence-card16 display (index+ boffset 2) buffer 0 dst-chunk + #+clx-little-endian ;; Byte swap for little-endian + #'byte-swap-card16) + (if translated-width + (when overall-width (incf overall-width translated-width)) + (setq overall-width nil)) + (when (index-plusp dst-chunk) + (setf (aref buffer-bbuf boffset) dst-chunk) + (setf (aref buffer-bbuf (index+ boffset 1)) offset) + (index-incf boffset (index+ dst-chunk dst-chunk 2))) + (setq offset 0) + (cond ((null new-font) + ;; Don't stop if translate copied whole chunk + (unless (index= src-chunk dst-chunk) + (setq stop-p t))) + ((integerp new-font) (setq offset new-font)) + ((type? new-font 'font) + (setq font new-font) + (let ((font-id (font-id font)) + (buffer-boffset boffset)) + (declare (type resource-id font-id) + (type array-index buffer-boffset)) + ;; This changes the gcontext font in the SERVER + ;; Update the gcontext cache (both local and server state) + (let ((local-state (gcontext-local-state gcontext)) + (server-state (gcontext-server-state gcontext))) + (declare (type gcontext-state local-state server-state)) + (setf (gcontext-internal-font-obj server-state) font + (gcontext-internal-font server-state) font-id) + (without-interrupts + (setf (gcontext-internal-font-obj local-state) font + (gcontext-internal-font local-state) font-id))) + (card8-put 0 #xff) + (card8-put 1 (ldb (byte 8 24) font-id)) + (card8-put 2 (ldb (byte 8 16) font-id)) + (card8-put 3 (ldb (byte 8 8) font-id)) + (card8-put 4 (ldb (byte 8 0) font-id))) + (index-incf boffset 5))) + ))))) + (values next-start width))) + +(defun draw-image-glyph (drawable gcontext x y elt + &key translate width (size :default)) + ;; Returns true if elt is output, nil if translate refuses to output it. + ;; Second result is overall width, if known. An initial font change is + ;; allowed from translate. + (declare (type drawable drawable) + (type gcontext gcontext) + (type int16 x y) + (type (or null int32) width) + (type index-size size)) + (declare (type (or null translation-function) translate) + (downward-funarg #+Genera * #-Genera translate)) + (declare (values boolean (or null int32))) + (let* ((display (gcontext-display gcontext)) + (result t) + (opcode *x-imagetext8*)) + (declare (type display display)) + (let ((vector (allocate-gcontext-state))) + (declare (type gcontext-state vector)) + (setf (aref vector 0) elt) + (multiple-value-bind (new-start new-font translate-width) + (funcall (or translate #'translate-default) + vector 0 1 (gcontext-font gcontext t) vector 1) + ;; Allow translate to set a new font + (when (type? new-font 'font) + (setf (gcontext-font gcontext) new-font) + (multiple-value-setq (new-start new-font translate-width) + (funcall translate vector 0 1 new-font vector 1))) + ;; If new-start is zero, translate refuses to output it + (setq result (index-plusp new-start) + elt (aref vector 1)) + (deallocate-gcontext-state vector) + (when translate-width (setq width translate-width)))) + (when result + (when (eql size 16) + (setq opcode *x-imagetext16*) + (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) + (with-buffer-request (display opcode :gc-force gcontext) + (drawable drawable) + (gcontext gcontext) + (data 1) ;; 1 character + (int16 x y) + (card8 (ldb (byte 8 0) elt)) + (card8 (ldb (byte 8 8) elt))) + (values t width)))) + +(defun draw-image-glyphs (drawable gcontext x y sequence + &key (start 0) end width translate (size :default)) + ;; An initial font change is allowed from translate, but any subsequent font + ;; change or horizontal motion will cause termination (because the protocol + ;; doesn't support chaining). [Alternatively, font changes could be accepted + ;; as long as they are accompanied with a width return value, or always + ;; accept font changes and call text-width as required. However, horizontal + ;; motion can't really be accepted, due to semantics.] First result is new + ;; start, if end was not reached. Second result is overall width, if known. + (declare (type drawable drawable) + (type gcontext gcontext) + (type int16 x y) + (type array-index start) + (type (or null array-index) end) + (type sequence sequence) + (type (or null int32) width) + (type index-size size)) + (declare (type (or null translation-function) translate) + (downward-funarg #+Genera * #-Genera translate)) + (declare (values (or null array-index) (or null int32))) + (unless end (setq end (length sequence))) + (ecase size + ((:default 8) + (draw-image-glyphs8 drawable gcontext x y sequence start end width translate)) + (16 + (draw-image-glyphs16 drawable gcontext x y sequence start end width translate)))) + +(defun draw-image-glyphs8 (drawable gcontext x y sequence start end width translate) + ;; An initial font change is allowed from translate, but any subsequent font + ;; change or horizontal motion will cause termination (because the protocol + ;; doesn't support chaining). [Alternatively, font changes could be accepted + ;; as long as they are accompanied with a width return value, or always + ;; accept font changes and call text-width as required. However, horizontal + ;; motion can't really be accepted, due to semantics.] First result is new + ;; start, if end was not reached. Second result is overall width, if known. + (declare (type drawable drawable) + (type gcontext gcontext) + (type int16 x y) + (type array-index start) + (type sequence sequence) + (type (or null array-index) end) + (type (or null int32) width)) + (declare (type (or null translation-function) translate) + (downward-funarg translate)) + (declare (values (or null array-index) (or null int32))) + (do* ((display (gcontext-display gcontext)) + (length (index- end start)) + ;; Should metrics-p be T? Don't want to pass a NIL font into translate... + (font (gcontext-font gcontext t)) + (font-change nil) + (new-start) (translated-width) (chunk)) + (nil) ;; forever + (declare (type display display) + (type array-index length) + (type (or null array-index) new-start chunk)) + + (when font-change + (setf (gcontext-font gcontext) font)) + (block change-font + (with-buffer-request (display *x-imagetext8* :gc-force gcontext :length length) + (drawable drawable) + (gcontext gcontext) + (int16 x y) + (progn + ;; Don't let any flushes happen since we manually set the request + ;; length when we're done. + (with-buffer-flush-inhibited (display) + ;; Translate the sequence into the buffer + (multiple-value-setq (new-start font translated-width) + (funcall (or translate #'translate-default) sequence start end + font buffer-bbuf (index+ buffer-boffset 16))) + ;; Number of glyphs translated + (setq chunk (index- new-start start)) + ;; Check for initial font change + (when (and (index-zerop chunk) (type? font 'font)) + (setq font-change t) ;; Loop around changing font + (return-from change-font)) + ;; Quit when nothing translated + (when (index-zerop chunk) + (return-from draw-image-glyphs8 new-start)) + ;; Update buffer pointers + (data-put 1 chunk) + (let ((blen (lround (index+ 16 chunk)))) + (length-put 2 (index-ash blen -2)) + (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) + ;; Normal exit + (return-from draw-image-glyphs8 + (values (if (index= chunk length) nil new-start) + (or translated-width width)))))) + +(defun draw-image-glyphs16 (drawable gcontext x y sequence start end width translate) + ;; An initial font change is allowed from translate, but any subsequent font + ;; change or horizontal motion will cause termination (because the protocol + ;; doesn't support chaining). [Alternatively, font changes could be accepted + ;; as long as they are accompanied with a width return value, or always + ;; accept font changes and call text-width as required. However, horizontal + ;; motion can't really be accepted, due to semantics.] First result is new + ;; start, if end was not reached. Second result is overall width, if known. + (declare (type drawable drawable) + (type gcontext gcontext) + (type int16 x y) + (type array-index start) + (type sequence sequence) + (type (or null array-index) end) + (type (or null int32) width)) + (declare (type (or null translation-function) translate) + (downward-funarg translate)) + (declare (values (or null array-index) (or null int32))) + (do* ((display (gcontext-display gcontext)) + (length (index- end start)) + ;; Should metrics-p be T? Don't want to pass a NIL font into translate... + (font (gcontext-font gcontext t)) + (font-change nil) + (new-start) (translated-width) (chunk) + (buffer (buffer-tbuf16 display))) + (nil) ;; forever + + (declare (type display display) + (type array-index length) + (type (or null array-index) new-start chunk) + (type buffer-text16 buffer)) + (when font-change + (setf (gcontext-font gcontext) font)) + + (block change-font + (with-buffer-request (display *x-imagetext16* :gc-force gcontext :length length) + (drawable drawable) + (gcontext gcontext) + (int16 x y) + (progn + ;; Don't let any flushes happen since we manually set the request + ;; length when we're done. + (with-buffer-flush-inhibited (display) + ;; Translate the sequence into the buffer + (multiple-value-setq (new-start font translated-width) + (funcall (or translate #'translate-default) sequence start end + font buffer 0)) + ;; Number of glyphs translated + (setq chunk (index- new-start start)) + ;; Check for initial font change + (when (and (index-zerop chunk) (type? font 'font)) + (setq font-change t) ;; Loop around changing font + (return-from change-font)) + ;; Quit when nothing translated + (when (index-zerop chunk) + (return-from draw-image-glyphs16 new-start)) + (write-sequence-card16 display (index+ buffer-boffset 16) buffer 0 chunk + #+clx-little-endian ;; Byte swap for little-endian + #'byte-swap-card16) + ;; Update buffer pointers + (data-put 1 chunk) + (let ((blen (lround (index+ 16 (index-ash chunk 1))))) + (length-put 2 (index-ash blen -2)) + (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) + ;; Normal exit + (return-from draw-image-glyphs16 + (values (if (index= chunk length) nil new-start) + (or translated-width width)))))) + + +;;----------------------------------------------------------------------------- + +(defun display-keycode-range (display) + (declare (type display display)) + (declare (values min max)) + (values (display-min-keycode display) + (display-max-keycode display))) + +;; Should this signal device-busy like the pointer-mapping setf, and return a +;; boolean instead (true for success)? Alternatively, should the +;; pointer-mapping setf be changed to set-pointer-mapping with a (member +;; :success :busy) result? + +(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) + ;; Setf ought to allow multiple values. + (declare (type display display) + (type sequence shift lock control mod1 mod2 mod3 mod4 mod5)) + (declare (values (member :success :busy :failed))) + (let* ((keycodes-per-modifier (index-max (length shift) + (length lock) + (length control) + (length mod1) + (length mod2) + (length mod3) + (length mod4) + (length mod5))) + (data (make-array (index* 8 keycodes-per-modifier) + :element-type 'card8 + :initial-element 0))) + (replace data shift) + (replace data lock :start1 keycodes-per-modifier) + (replace data control :start1 (index* 2 keycodes-per-modifier)) + (replace data mod1 :start1 (index* 3 keycodes-per-modifier)) + (replace data mod2 :start1 (index* 4 keycodes-per-modifier)) + (replace data mod3 :start1 (index* 5 keycodes-per-modifier)) + (replace data mod4 :start1 (index* 6 keycodes-per-modifier)) + (replace data mod5 :start1 (index* 7 keycodes-per-modifier)) + (with-buffer-request-and-reply (display *x-setmodifiermapping* 4 :sizes 8) + ((data keycodes-per-modifier) + ((sequence :format card8) data)) + (values (member8-get 1 :success :busy :failed))))) + +(defun modifier-mapping (display) + ;; each value is a list of integers + (declare (type display display)) + (declare (values shift lock control mod1 mod2 mod3 mod4 mod5)) + (let ((lists nil)) + (with-buffer-request-and-reply (display *x-getmodifiermapping* nil :sizes 8) + () + (do* ((keycodes-per-modifier (card8-get 1)) + (advance-by *replysize* keycodes-per-modifier) + (keys nil nil) + (i 0 (index+ i 1))) + ((index= i 8)) + (advance-buffer-offset advance-by) + (dotimes (j keycodes-per-modifier) + (let ((key (read-card8 j))) + (unless (zerop key) + (push key keys)))) + (push (nreverse keys) lists))) + (values-list (nreverse lists)))) + +;; Either we will want lots of defconstants for well-known values, or perhaps +;; an integer-to-keyword translation function for well-known values. + +(defun change-keyboard-mapping + (display keysyms &key (start 0) end (first-keycode start)) + ;; start/end give subrange of keysyms + ;; first-keycode is the first-keycode to store at + (declare (type display display) + (type array-index start) + (type card8 first-keycode) + (type (or null array-index) end) + (type (array * (* *)) keysyms)) + (let* ((keycode-end (or end (array-dimension keysyms 0))) + (keysyms-per-keycode (array-dimension keysyms 1)) + (length (index- keycode-end start)) + (size (index* length keysyms-per-keycode)) + (request-length (index+ size 2))) + (declare (type array-index keycode-end keysyms-per-keycode length request-length)) + (with-buffer-request (display *x-setkeyboardmapping* + :length (index-ash request-length 2) + :sizes (32)) + (data length) + (length request-length) + (card8 first-keycode keysyms-per-keycode) + (progn + (do ((limit (index-ash (buffer-size display) -2)) + (w (index+ 2 (index-ash buffer-boffset -2))) + (i start (index+ i 1))) + ((index>= i keycode-end) + (setf (buffer-boffset display) (index-ash w 2))) + (declare (type array-index limit w i)) + (when (index> w limit) + (buffer-flush display) + (setq w (index-ash (buffer-boffset display) -2))) + (do ((j 0 (index+ j 1))) + ((index>= j keysyms-per-keycode)) + (declare (type array-index j)) + (card29-put (index* w 4) (aref keysyms i j)) + (index-incf w))))))) + +(defun keyboard-mapping (display &key first-keycode start end data) + ;; First-keycode specifies which keycode to start at (defaults to min-keycode). + ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode) + ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)). + ;; If DATA is specified, the results are put there. + (declare (type display display) + (type (or null card8) first-keycode) + (type (or null array-index) start end) + (type (or null (array * (* *))) data)) + (declare (values (array * (* *)))) + (unless first-keycode (setq first-keycode (display-min-keycode display))) + (unless start (setq start first-keycode)) + (unless end (setq end (1+ (display-max-keycode display)))) + (with-buffer-request-and-reply (display *x-getkeyboardmapping* nil :sizes (8 32)) + ((card8 first-keycode (index- end start))) + (do* ((keysyms-per-keycode (card8-get 1)) + (bytes-per-keycode (* keysyms-per-keycode 4)) + (advance-by *replysize* bytes-per-keycode) + (keycode-count (floor (card32-get 4) keysyms-per-keycode) + (index- keycode-count 1)) + (result (if (and (arrayp data) + (= (array-rank data) 2) + (>= (array-dimension data 0) (index+ start keycode-count)) + (>= (array-dimension data 1) keysyms-per-keycode)) + data + (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode) + :element-type 'keysym :initial-element 0))) + (i start (1+ i))) + ((zerop keycode-count) (setq data result)) + (advance-buffer-offset advance-by) + (dotimes (j keysyms-per-keycode) + (setf (aref result i j) (card29-get (* j 4)))))) + data) diff --git a/clx/translate.lisp b/clx/translate.lisp new file mode 100644 index 0000000000000000000000000000000000000000..18434e4ba55512f02e99bdeb91a7008988bcd3c9 --- /dev/null +++ b/clx/translate.lisp @@ -0,0 +1,619 @@ +;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- + +;;; +;;; TEXAS INSTRUMENTS INCORPORATED +;;; P.O. BOX 2909 +;;; AUSTIN, TEXAS 78769 +;;; +;;; Copyright (C) 1987 Texas Instruments Incorporated. +;;; +;;; Permission is granted to any individual or institution to use, copy, modify, +;;; and distribute this software, provided that this complete copyright and +;;; permission notice is maintained, intact, in all copies and supporting +;;; documentation. +;;; +;;; Texas Instruments Incorporated provides this software "as is" without +;;; express or implied warranty. +;;; + +(in-package :xlib) + +(export '(define-keysym-set + keysym-set + define-keysym + undefine-keysym + default-keysym-translate + keysym + character->keysyms + keycode->keysym + keysym->character + default-keysym-index + keycode->character + state-keysym-p + mapping-notify + keysym-in-map-p + character-in-map-p + keysym->keycodes + )) + +(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym) + +(defun define-keysym-set (set first-keysym last-keysym) + ;; Define all keysyms from first-keysym up to and including + ;; last-keysym to be in SET (returned from the keysym-set function). + ;; Signals an error if the keysym range overlaps an existing set. + (declare (type keyword set) + (type keysym first-keysym last-keysym)) + (when (> first-keysym last-keysym) + (rotatef first-keysym last-keysym)) + (setq *keysym-sets* (delete set *keysym-sets* :key #'car)) + (dolist (set *keysym-sets*) + (let ((first (second set)) + (last (third set))) + (when (or (<= first first-keysym last) + (<= first last-keysym last)) + (error "Keysym range overlaps existing set ~s" set)))) + (push (list set first-keysym last-keysym) *keysym-sets*) + set) + +(defun keysym-set (keysym) + ;; Return the character code set name of keysym + (declare (type keysym keysym) + (values keyword)) + (dolist (set *keysym-sets*) + (let ((first (second set)) + (last (third set))) + (when (<= first keysym last) + (return (first set)))))) + +(eval-when (compile eval load) ;; Required for Vaxlisp ... +(defmacro keysym (keysym &rest bytes) + ;; Build a keysym. + ;; If KEYSYM is an integer, it is used as the most significant bits of + ;; the keysym, and BYTES are used to specify low order bytes. The last + ;; parameter is always byte4 of the keysym. If KEYSYM is not an + ;; integer, the keysym associated with KEYSYM is returned. + ;; + ;; This is a macro and not a function macro to promote compile-time + ;; lookup. All arguments are evaluated. + (declare (type t keysym) + (type list bytes) + (values keysym)) + (typecase keysym + ((integer 0) + (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b)))) + (otherwise + (or (car (character->keysyms keysym)) + (error "~s Isn't the name of a keysym" keysym))))) +) + +(defvar *keysym->character-map* + (make-hash-table :test (keysym->character-map-test) :size 400)) + +;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask) +;; With the following accessor macros. Everything after OBJECT is optional. + +(defmacro keysym-mapping-object (keysym-mapping) + ;; Parameter to translate + `(first ,keysym-mapping)) + +(defmacro keysym-mapping-translate (keysym-mapping) + ;; Function to be called with parameters (display state OBJECT) + ;; when translating KEYSYM and modifiers and mask are satisfied. + `(second ,keysym-mapping)) + +(defmacro keysym-mapping-lowercase (keysym-mapping) + ;; LOWERCASE is used for uppercase alphabetic keysyms. The value + ;; is the associated lowercase keysym. + `(third ,keysym-mapping)) + +(defmacro keysym-mapping-modifiers (keysym-mapping) + ;; MODIFIERS is either a modifier-mask or list containing intermixed + ;; keysyms and state-mask-keys specifying when to use this + ;; keysym-translation. + `(fourth ,keysym-mapping)) + +(defmacro keysym-mapping-mask (keysym-mapping) + ;; MASK is either a modifier-mask or list containing intermixed + ;; keysyms and state-mask-keys specifying which modifiers to look at + ;; (i.e. modifiers not specified are don't-cares) + `(fifth ,keysym-mapping)) + +(defvar *default-keysym-translate-mask* + (the (or (member :modifiers) mask16 list) ; (list (or keysym state-mask-key)) + (logand #xff (lognot (make-state-mask :lock)))) + "Default keysym state mask to use during keysym-translation.") + +(defun define-keysym (object keysym &key lowercase translate modifiers mask display) + ;; Define the translation from keysym/modifiers to a (usually + ;; character) object. ANy previous keysym definition with + ;; KEYSYM and MODIFIERS is deleted before adding the new definition. + ;; + ;; MODIFIERS is either a modifier-mask or list containing intermixed + ;; keysyms and state-mask-keys specifying when to use this + ;; keysym-translation. The default is NIL. + ;; + ;; MASK is either a modifier-mask or list containing intermixed + ;; keysyms and state-mask-keys specifying which modifiers to look at + ;; (i.e. modifiers not specified are don't-cares). + ;; If mask is :MODIFIERS then the mask is the same as the modifiers + ;; (i.e. modifiers not specified by modifiers are don't cares) + ;; The default mask is *default-keysym-translate-mask* + ;; + ;; If DISPLAY is specified, the translation will be local to DISPLAY, + ;; otherwise it will be the default translation for all displays. + ;; + ;; LOWERCASE is used for uppercase alphabetic keysyms. The value + ;; is the associated lowercase keysym. This information is used + ;; by the keysym-both-case-p predicate (for caps-lock computations) + ;; and by the keysym-downcase function. + ;; + ;; TRANSLATE will be called with parameters (display state OBJECT) + ;; when translating KEYSYM and modifiers and mask are satisfied. + ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*)) + ;; (or modifiers 0))) + ;; when mask and modifiers aren't lists of keysyms] + ;; The default is #'default-keysym-translate + ;; + (declare (type (or string-char t) object) + (type keysym keysym) + (type (or null mask16 list) ;; (list (or keysym state-mask-key)) + modifiers) + (type (or null (member :modifiers) mask16 list) ;; (list (or keysym state-mask-key)) + mask) + (type (or null display) display) + (type (or null keysym) lowercase) + (type (function (display card16 t) t) translate)) + (flet ((merge-keysym-mappings (new old) + ;; Merge new keysym-mapping with list of old mappings. + ;; Ensure that the mapping with no modifiers or mask comes first. + (let* ((key (keysym-mapping-modifiers new)) + (merge (delete key old :key #'cadddr :test #'equal))) + (if key + (nconc merge (list new)) + (cons new merge)))) + (mask-check (mask) + (unless (or (numberp mask) + (dolist (element mask t) + (unless (or (find element *state-mask-vector*) + (gethash element *keysym->character-map*)) + (return nil)))) + (x-type-error mask '(or mask16 (list (or modifier-key modifier-keysym))))))) + (let ((entry + ;; Create with a single LIST call, to ensure cdr-coding + (cond + (mask + (unless (eq mask :modifiers) + (mask-check mask)) + (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers))) + (error "Mask with no modifiers")) + (list object translate lowercase modifiers mask)) + (modifiers (mask-check modifiers) + (list object translate lowercase modifiers)) + (lowercase (list object translate lowercase)) + (translate (list object translate)) + (t (list object))))) + (if display + (let ((previous (assoc keysym (display-keysym-translation display)))) + (if previous + (setf (cdr previous) (merge-keysym-mappings entry (cdr previous))) + (push (list keysym entry) (display-keysym-translation display)))) + (setf (gethash keysym *keysym->character-map*) + (merge-keysym-mappings entry (gethash keysym *keysym->character-map*))))) + object)) + +(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) + ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS. + ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists. + (declare (type (or string-char t) object) + (type keysym keysym) + (type (or null mask16 list) ;; (list (or keysym state-mask-key)) + modifiers) + (type (or null display) display)) + (flet ((match (key entry) + (let ((object (car key)) + (modifiers (cdr key))) + (or (eql object (keysym-mapping-object entry)) + (equal modifiers (keysym-mapping-modifiers entry)))))) + (let* (entry + (previous (if display + (cdr (setq entry (assoc keysym (display-keysym-translation display)))) + (gethash keysym *keysym->character-map*))) + (key (cons object modifiers))) + (when (and previous (find key previous :test #'match)) + (setq previous (delete key previous :test #'match)) + (if display + (setf (cdr entry) previous) + (setf (gethash keysym *keysym->character-map*) previous)))))) + +(defun keysym-downcase (keysym) + ;; If keysym has a lower-case equivalent, return it, otherwise return keysym. + (declare (type keysym keysym)) + (declare (values keysym)) + (let ((translations (gethash keysym *keysym->character-map*))) + (or (and translations (keysym-mapping-lowercase (first translations))) keysym))) + +(defun keysym-uppercase-alphabetic-p (keysym) + ;; Returns T if keysym is uppercase-alphabetic. + ;; I.E. If it has a lowercase equivalent. + (declare (type keysym keysym)) + (declare (values (or null keysym))) + (let ((translations (gethash keysym *keysym->character-map*))) + (and translations + (keysym-mapping-lowercase (first translations))))) + +(defun character->keysyms (character &optional display) + ;; Given a character, return a list of all matching keysyms. + ;; If DISPLAY is given, translations specific to DISPLAY are used, + ;; otherwise only global translations are used. + ;; Implementation dependent function. + ;; May be slow [i.e. do a linear search over all known keysyms] + (declare (type t character) + (type (or null display) display) + (values (list keysym))) + (let ((result nil)) + (when display + (dolist (mapping (display-keysym-translation display)) + (when (eql character (second mapping)) + (push (first mapping) result)))) + (maphash #'(lambda (keysym mappings) + (dolist (mapping mappings) + (when (eql (keysym-mapping-object mapping) character) + (pushnew keysym result)))) + *keysym->character-map*) + result)) + +(eval-when (compile eval load) ;; Required for Symbolics... +(defconstant character-set-switch-keysym (keysym 255 126)) +(defconstant left-shift-keysym (keysym 255 225)) +(defconstant right-shift-keysym (keysym 255 226)) +(defconstant left-control-keysym (keysym 255 227)) +(defconstant right-control-keysym (keysym 255 228)) +(defconstant caps-lock-keysym (keysym 255 229)) +(defconstant shift-lock-keysym (keysym 255 230)) +(defconstant left-meta-keysym (keysym 255 231)) +(defconstant right-meta-keysym (keysym 255 232)) +(defconstant left-alt-keysym (keysym 255 233)) +(defconstant right-alt-keysym (keysym 255 234)) +(defconstant left-super-keysym (keysym 255 235)) +(defconstant right-super-keysym (keysym 255 236)) +(defconstant left-hyper-keysym (keysym 255 237)) +(defconstant right-hyper-keysym (keysym 255 238)) +) ;; end eval-when + + +;;----------------------------------------------------------------------------- +;; Keysym mapping functions + +(defun display-keyboard-mapping (display) + (declare (type display display)) + (declare (values (simple-array keysym (display-max-keycode keysyms-per-keycode)))) + (or (display-keysym-mapping display) + (setf (display-keysym-mapping display) (keyboard-mapping display)))) + +(defun keycode->keysym (display keycode keysym-index) + (declare (type display display) + (type card8 keycode) + (type card8 keysym-index) + (values keysym)) + (let* ((mapping (display-keyboard-mapping display)) + (keysym (aref mapping keycode keysym-index))) + (declare (type (simple-array keysym (* *)) mapping) + (type keysym keysym)) + ;; The keysym-mapping is brain dammaged. + ;; Mappings for both-case alphabetic characters have the + ;; entry for keysym-index zero set to the uppercase keysym + ;; (this is normally where the lowercase keysym goes), and the + ;; entry for keysym-index one is zero. + (cond ((zerop keysym-index) ; Lowercase alphabetic keysyms + (keysym-downcase keysym)) + ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym + (aref mapping keycode 0)) + (t keysym)))) + +(defun keysym->character (display keysym &optional (state 0)) + ;; Find the character associated with a keysym. + ;; STATE is used for adding char-bits to character as follows: + ;; control -> char-control-bit + ;; mod-1 -> char-meta-bit + ;; mod-2 -> char-super-bit + ;; mod-3 -> char-hyper-bit + ;; Implementation dependent function. + (declare (type display display) + (type keysym keysym) + (type card16 state)) + (declare (values (or null character))) + (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display)))) + (mapping (or ;; Find the matching display mapping + (dolist (mapping display-mappings) + (when (mapping-matches-p display state mapping) + (return mapping))) + ;; Find the matching static mapping + (dolist (mapping (gethash keysym *keysym->character-map*)) + (when (mapping-matches-p display state mapping) + (return mapping)))))) + (when mapping + (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate) + display state (keysym-mapping-object mapping))))) + +(defun mapping-matches-p (display state mapping) + ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY + (declare (type display display) + (type mask16 state) + (type list mapping)) + (declare (values boolean)) + (flet + ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0)) + ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask. + ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified, + ;; otherwise ignore unknown modifiers. + (declare (type list display-mapping) ; Alist of (keysym . mask) + (type (or mask16 list) modifiers) + (type mask16 mask)) + (declare (values (or null mask16))) + (if (numberp modifiers) + modifiers + (dolist (modifier modifiers mask) + (declare (type symbol modifier)) + (let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq))) + (setq mask + (logior mask + (if bit + (ash 1 bit) + (or (cdr (assoc modifier display-mapping)) + ;; bad modifier + (if errorp + (return-from modifiers->mask nil) + 0)))))))))) + + (let* ((display-mapping (get-display-modifier-mapping display)) + (mapping-modifiers (keysym-mapping-modifiers mapping)) + (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t) + (return-from mapping-matches-p nil))) + (mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default. + (if mapping-modifiers ; If no modifiers, match anything. + *default-keysym-translate-mask* + 0))) + (mask (if (eq mapping-mask :modifiers) + modifiers + (modifiers->mask display-mapping mapping-mask nil)))) + (declare (type mask16 modifiers mask)) + (= (logand state mask) modifiers)))) + +(defun default-keysym-translate (display state object) + ;; If object is a character, char-bits are set from state. + ;; + ;; [the following isn't implemented (should it be?)] + ;; If object is a list, it is an alist with entries: + ;; (string-char [modifiers] [mask-modifiers]) + ;; When MODIFIERS are specified, this character translation + ;; will only take effect when the specified modifiers are pressed. + ;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. + ;; When MASK-MODIFIERS is missing, all other modifiers are ignored. + ;; In ambiguous cases, the most specific translation is used. + (declare (type display display) + (type card16 state) + (type t object)) + (declare (values t)) ;; Object returned by keycode->character + (macrolet ((keystate-p (state keyword) + `(the boolean + (logbitp ,(position keyword *state-mask-vector*) + ,state)))) + (when (characterp object) + (when (keystate-p state :control) + (setf (char-bit object :control) 1)) + (when (state-keysymp display state left-meta-keysym) + (setf (char-bit object :meta) 1)) + (when (state-keysymp display state left-super-keysym) + (setf (char-bit object :super) 1)) + (when (state-keysymp display state left-hyper-keysym) + (setf (char-bit object :hyper) 1)))) + object) + +(defun default-keysym-index (display keycode state) + ;; Returns a keysym-index for use with keycode->character + (declare (values card8)) + (macrolet ((keystate-p (state keyword) + `(the boolean + (logbitp ,(position keyword *state-mask-vector*) + ,state)))) + (let* ((mapping (display-keyboard-mapping display)) + (keysyms-per-keycode (array-dimension mapping 1)) + (symbolp (and (> keysyms-per-keycode 2) + (state-keysymp display state character-set-switch-keysym))) + (result (if symbolp 2 0))) + (declare (type (simple-array keysym (* *)) mapping) + (type boolean symbolp) + (type card8 keysyms-per-keycode result)) + (when (and (< result keysyms-per-keycode) + (keysym-shift-p display state (keysym-uppercase-alphabetic-p + (aref mapping keycode 0)))) + (incf result)) + result))) + +(defun keysym-shift-p (display state uppercase-alphabetic-p &key + shift-lock-xors + (control-modifiers + '#.(list left-meta-keysym left-super-keysym left-hyper-keysym))) + (declare (type display display) + (type card16 state) + (type boolean uppercase-alphabetic-p) + (type boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same + ;;; as neither if the character is alphabetic. + (declare (values boolean)) + (macrolet ((keystate-p (state keyword) + `(the boolean + (logbitp ,(position keyword *state-mask-vector*) + ,state)))) + (let* ((controlp (or (keystate-p state :control) + (dolist (modifier control-modifiers) + (when (state-keysymp display state modifier) + (return t))))) + (shiftp (keystate-p state :shift)) + (lockp (keystate-p state :lock)) + (alphap (or uppercase-alphabetic-p + (not (state-keysymp display #.(make-state-mask :lock) + caps-lock-keysym))))) + (declare (type boolean controlp shiftp lockp alphap)) + ;; Control keys aren't affected by lock + (unless controlp + ;; Not a control character - check state of lock modifier + (when (and lockp + alphap + (or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors + (setq shiftp (not shiftp)))) + shiftp))) + +;;; default-keysym-index implements the following tables: +;;; +;;; control shift caps-lock character character +;;; 0 0 0 #\a #\8 +;;; 0 0 1 #\A #\8 +;;; 0 1 0 #\A #\* +;;; 0 1 1 #\A #\* +;;; 1 0 0 #\control-A #\control-8 +;;; 1 0 1 #\control-A #\control-8 +;;; 1 1 0 #\control-shift-a #\control-* +;;; 1 1 1 #\control-shift-a #\control-* +;;; +;;; control shift shift-lock character character +;;; 0 0 0 #\a #\8 +;;; 0 0 1 #\A #\* +;;; 0 1 0 #\A #\* +;;; 0 1 1 #\A #\8 +;;; 1 0 0 #\control-A #\control-8 +;;; 1 0 1 #\control-A #\control-* +;;; 1 1 0 #\control-shift-a #\control-* +;;; 1 1 1 #\control-shift-a #\control-8 + +(defun keycode->character (display keycode state &key keysym-index + (keysym-index-function #'default-keysym-index)) + ;; keysym-index defaults to the result of keysym-index-function which + ;; is called with the following parameters: + ;; (char0 state caps-lock-p keysyms-per-keycode) + ;; where char0 is the "character" object associated with keysym-index 0 and + ;; caps-lock-p is non-nil when the keysym associated with the lock + ;; modifier is for caps-lock. + ;; STATE is also used for setting char-bits: + ;; control -> char-control-bit + ;; mod-1 -> char-meta-bit + ;; mod-2 -> char-super-bit + ;; mod-3 -> char-hyper-bit + ;; Implementation dependent function. + (declare (type display display) + (type card8 keycode) + (type card16 state) + (type (or null card8) keysym-index) + (type (or null (function (string-char card16 boolean card8) card8)) + keysym-index-function)) + (declare (values (or null character))) + (let* ((index (or keysym-index + (funcall keysym-index-function display keycode state))) + (keysym (if index (keycode->keysym display keycode index) 0))) + (declare (type (or null card8) index) + (type keysym keysym)) + (when (plusp keysym) + (keysym->character display keysym state)))) + +(defun get-display-modifier-mapping (display) + (labels ((keysym-replace (display modifiers mask &aux result) + (dolist (modifier modifiers result) + (push (cons (keycode->keysym display modifier 0) mask) result)))) + (or (display-modifier-mapping display) + (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5) + (modifier-mapping display) + (setf (display-modifier-mapping display) + (nconc (keysym-replace display shift #.(make-state-mask :shift)) + (keysym-replace display lock #.(make-state-mask :lock)) + (keysym-replace display control #.(make-state-mask :control)) + (keysym-replace display mod1 #.(make-state-mask :mod-1)) + (keysym-replace display mod2 #.(make-state-mask :mod-2)) + (keysym-replace display mod3 #.(make-state-mask :mod-3)) + (keysym-replace display mod4 #.(make-state-mask :mod-4)) + (keysym-replace display mod5 #.(make-state-mask :mod-5)))))))) + +(defun state-keysymp (display state keysym) + ;; Returns T when a modifier key associated with KEYSYM is on in STATE + (declare (type display display) + (type card16 state) + (type keysym keysym)) + (declare (values boolean)) + (let* ((mapping (get-display-modifier-mapping display)) + (mask (assoc keysym mapping))) + (and mask (plusp (logand state (cdr mask)))))) + +(defun mapping-notify (display request start count) + ;; Called on a mapping-notify event to update + ;; the keyboard-mapping cache in DISPLAY + (declare (type display display) + (type (member :modifier :keyboard :pointer) request) + (type card8 start count) + (ignore count start)) + ;; Invalidate the keyboard mapping to force the next key translation to get it + (case request + (:modifier + (setf (display-modifier-mapping display) nil)) + (:keyboard + (setf (display-keysym-mapping display) nil)))) + +(defun keysym-in-map-p (display keysym keymap) + ;; Returns T if keysym is found in keymap + (declare (type display display) + (type keysym keysym) + (type (bit-vector 256) keymap)) + (declare (values boolean)) + ;; The keysym may appear in the keymap more than once, + ;; So we have to search the entire keysym map. + (do* ((min (display-min-keycode display)) + (max (display-max-keycode display)) + (map (display-keyboard-mapping display)) + (jmax (min 2 (array-dimension map 1))) + (i min (1+ i))) + ((> i max)) + (declare (type card8 min max jmax) + (type (simple-array keysym (* *)) map)) + (when (and (plusp (aref keymap i)) + (dotimes (j jmax) + (when (= keysym (aref map i j)) (return t)))) + (return t)))) + +(defun character-in-map-p (display character keymap) + ;; Implementation dependent function. + ;; Returns T if character is found in keymap + (declare (type display display) + (type character character) + (type (bit-vector 256) keymap)) + (declare (values boolean)) + ;; Check all one bits in keymap + (do* ((min (display-min-keycode display)) + (max (display-max-keycode display)) + (jmax (array-dimension (display-keyboard-mapping display) 1)) + (i min (1+ i))) + ((> i max)) + (declare (type card8 min max jmax)) + (when (and (plusp (aref keymap i)) + ;; Match when character is in mapping for this keycode + (dotimes (j jmax) + (when (eql character (keycode->character display i 0 :keysym-index j)) + (return t)))) + (return t)))) + +(defun keysym->keycodes (display keysym) + ;; Return keycodes for keysym, as multiple values + (declare (type display display) + (type keysym keysym)) + (declare (values (or null keycode) (or null keycode) (or null keycode))) + ;; The keysym may appear in the keymap more than once, + ;; So we have to search the entire keysym map. + (do* ((min (display-min-keycode display)) + (max (display-max-keycode display)) + (map (display-keyboard-mapping display)) + (jmax (min 2 (array-dimension map 1))) + (i min (1+ i)) + (result nil)) + ((> i max) (values-list result)) + (declare (type card8 min max jmax) + (type (simple-array keysym (* *)) map)) + (dotimes (j jmax) + (when (= keysym (aref map i j)) + (push i result))))) diff --git a/hemlock/abbrev.lisp b/hemlock/abbrev.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a314b76b605400e55fa0f37cbd4344f5a6f16bb5 --- /dev/null +++ b/hemlock/abbrev.lisp @@ -0,0 +1,682 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Hemlock Word Abbreviation Mode +;;; by Jamie W. Zawinski +;;; 24 September 1985 +;;; +(in-package "HEMLOCK") + +;;;; These Things are Here: + +;;; C-X C-A Add Mode Word Abbrev +;;; Define a mode abbrev for the word before point. +;;; C-X + Add Global Word Abbrev +;;; Define a global abbrev for the word before point. +;;; C-X C-H Inverse Add Mode Word Abbrev +;;; Define expansion for mode abbrev before point. +;;; C-X - Inverse Add Global Word Abbrev +;;; Define expansion for global abbrev before point. +;;; Alt Space Abbrev Expand Only +;;; Expand abbrev without inserting anything. +;;; M-' Word Abbrev Prefix Mark +;;; Mark a prefix to be glued to an abbrev following. +;;; C-X U Unexpand Last Word +;;; Unexpands last abbrev or undoes C-X U. + +;;; List Word Abbrevs Shows definitions of all word abbrevs. +;;; Edit Word Abbrevs Lets you edit the definition list directly. +;;; Read Word Abbrev File <filename> Define word abbrevs from a definition file. +;;; Write Word Abbrev File Make a definition file from current abbrevs. + +;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc. +;;; Delete All Word Abbrevs Wipes them all. +;;; Delete Mode Word Abbrev Kills all Mode abbrev. +;;; Delete Global Word Abbrev Kills all Global abbrev. + +;;; Insert Word Abbrevs Inserts a list of current definitions in the +;;; format that Define Word Abbrevs uses. +;;; Define Word Abbrevs Defines set of abbrevs from a definition list in +;;; the buffer. +;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev, +;;; definition, or mode. + +;;; Append Incremental Word Abbrev File Appends to a file changed abbrev +;;; definitions since last dumping. + +(defmode "Abbrev" :major-p nil :transparent-p t :precedence 2.0) + + +(defvar *Global-Abbrev-Table* (make-hash-table :test #'equal) + "Hash table holding global abbrev definitions.") + +(defhvar "Abbrev Pathname Defaults" + "Holds the name of the last Abbrev-file written." + :value (pathname "abbrev.defns")) + +(defvar *new-abbrevs* () + "holds a list of abbrevs (and their definitions and modes) changed since saving.") + + +;;; C-X C-H Inverse Add Mode Word Abbrev +;;; Define a mode expansion for the word before point. + +(defcommand "Inverse Add Mode Word Abbrev" (p) + "Defines a mode word abbrev expansion for the word before the point." + "Defines a mode word abbrev expansion for the word before the point." + (declare (ignore p)) + (let ((word (prev-word 1 (current-point))) + (mode (buffer-major-mode (current-buffer)))) + (make-word-abbrev-command nil word nil mode))) + + +;;; C-X C-A Add Mode Word Abbrev +;;; Define mode abbrev for word before point. + +(defcommand "Add Mode Word Abbrev" (p) + "Defines a mode word abbrev for the word before the point. + With a positive argument, uses that many preceding words as the expansion. + With a zero argument, uses the region as the expansion. With a negative + argument, prompts for a word abbrev to delete in the current mode." + "Defines or deletes a mode word abbrev." + (if (and p (minusp p)) + (delete-mode-word-abbrev-command nil) + (let* ((val (if (eql p 0) + (region-to-string (current-region nil)) + (prev-word (or p 1) (current-point)))) + (mode (buffer-major-mode (current-buffer)))) + (make-word-abbrev-command nil nil val mode)))) + + + +;;; C-X - Inverse Add Global Word Abbrev +;;; Define global expansion for word before point. + +(defcommand "Inverse Add Global Word Abbrev" (p) + "Defines a Global expansion for the word before point." + "Defines a Global expansion for the word before point." + (declare (ignore p)) + (let ((word (prev-word 1 (current-point)))) + (make-word-abbrev-command nil word nil "Global"))) + + + +;;; C-X + Add Global Word Abbrev +;;; Define global Abbrev for word before point. + +(defcommand "Add Global Word Abbrev" (p) + "Defines a global word abbrev for the word before the point. + With a positive argument, uses that many preceding words as the expansion. + With a zero argument, uses the region as the expansion. With a negative + argument, prompts for a global word abbrev to delete." + "Defines or deletes a global word abbrev." + (if (and p (minusp p)) + (delete-global-word-abbrev-command nil) + (let ((val (if (eql p 0) + (region-to-string (current-region nil)) + (prev-word (or p 1) (current-point))))) + (make-word-abbrev-command nil nil val "Global")))) + + +;;;; Defining Abbrevs + +;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc. + +(defvar *global-abbrev-string-table* + (make-string-table :initial-contents '(("Global" . nil)))) + +(defcommand "Make Word Abbrev" (p &optional abbrev expansion mode) + "Defines an arbitrary word abbreviation. + Prompts for abbrev, expansion, and mode." + "Makes Abbrev be a word abbreviation for Expansion when in Mode. If + mode is \"Global\" then make a global abbrev." + (declare (ignore p)) + (unless mode + (setq mode + (prompt-for-keyword + (list *mode-names* *global-abbrev-string-table*) + :prompt "Mode of abbrev to add: " + :default "Global" + :help + "Type the mode of the Abbrev you want to add, or confirm for Global."))) + (let ((globalp (string-equal mode "Global"))) + (unless (or globalp (mode-major-p mode)) + (editor-error "~A is not a major mode." mode)) + (unless abbrev + (setq abbrev + (prompt-for-string + :trim t + :prompt + (list "~A abbreviation~@[ of ~S~]: " mode expansion) + :help + (list "Define a ~A word abbrev." mode)))) + (when (zerop (length abbrev)) + (editor-error "Abbreviation must be at least one character long.")) + (unless (every #'(lambda (ch) + (zerop (character-attribute :word-delimiter ch))) + (the simple-string abbrev)) + (editor-error "Word Abbrevs must be a single word.")) + (unless expansion + (setq expansion + (prompt-for-string + :prompt (list "~A expansion for ~S: " mode abbrev) + :help (list "Define the ~A expansion of ~S." mode abbrev)))) + (setq abbrev (string-downcase abbrev)) + (let* ((table (cond (globalp *global-abbrev-table*) + ((hemlock-bound-p 'Mode-Abbrev-Table :mode mode) + (variable-value 'Mode-Abbrev-Table :mode mode)) + (t + (let ((new (make-hash-table :test #'equal))) + (defhvar "Mode Abbrev Table" + "Hash Table of Mode Abbrevs" + :value new :mode mode) + new)))) + (old (gethash abbrev table))) + (when (or (not old) + (prompt-for-y-or-n + :prompt + (list "Current ~A definition of ~S is ~S.~%Redefine?" + mode abbrev old) + :default t + :help (list "Redefine the expansion of ~S." abbrev))) + (setf (gethash abbrev table) expansion) + (push (list abbrev expansion (if globalp nil mode)) + *new-abbrevs*))))) + + +;;; Alt Space Abbrev Expand Only +;;; Expand abbrev without inserting anything. + +(defcommand "Abbrev Expand Only" (p) + "This command expands the word before point into its abbrev definition + (if indeed it has one)." + "This command expands the word before point into its abbrev definition + (if indeed it has one)." + (declare (ignore p)) + (let* ((word (prev-word 1 (current-point))) + (glob (gethash (string-downcase word) *global-abbrev-table*)) + (mode (if (hemlock-bound-p 'Mode-Abbrev-Table) + (gethash (string-downcase word) + (value Mode-Abbrev-Table)))) + (end-word (reverse-find-attribute (copy-mark (current-point) + :right-inserting) + :word-delimiter #'zerop)) + (result (if mode mode glob))) + (when (or mode glob) + (delete-characters end-word (- (length word))) + (cond ((equal word (string-capitalize word)) + (setq result (string-capitalize result))) + ((equal word (string-upcase word)) + (setq result (string-upcase result)))) + (insert-string end-word result) + (unless (hemlock-bound-p 'last-expanded) + (defhvar "last expanded" + "Holds a mark, the last expanded abbrev, and its expansion in a list." + :buffer (current-buffer))) + (setf (value last-expanded) + (list (copy-mark (current-point) :right-inserting) + word result))) + (delete-mark end-word)) + (when (and (hemlock-bound-p 'prefix-mark) + (value prefix-mark)) + (delete-characters (value prefix-mark) 1) + (delete-mark (value prefix-mark)) + (setf (value prefix-mark) nil))) + + + +;;; This function returns the n words immediately before the mark supplied. + +(defun prev-word (n mark) + (let* ((mark-1 (reverse-find-attribute (copy-mark mark :temporary) + :word-delimiter #'zerop)) + (mark-2 (copy-mark mark-1))) + (dotimes (x n (region-to-string (region mark-2 mark-1))) + (reverse-find-attribute (mark-before mark-2) :word-delimiter)))) + + + +;;; M-' Word Abbrev Prefix Mark +;;; Mark a prefix to be glued to an abbrev following. + +;;; When "Abbrev Expand Only" expands the abbrev (because #\- is an expander) +;;; it will see that prefix-mark is non-nil, and will delete the #\- immediately +;;; after prefix-mark. + +(defcommand "Word Abbrev Prefix Mark" (p) + "Marks a prefix to be glued to an abbrev following." + "Marks a prefix to be glued to an abbrev following." + (declare (ignore p)) + (unless (hemlock-bound-p 'prefix-mark) + (defhvar "prefix mark" + "Holds a mark (or not) pointing to the current Prefix Mark." + :buffer (current-buffer))) + (when (value prefix-mark) + (delete-mark (value prefix-mark))) + (setf (value prefix-mark) (copy-mark (current-point) :right-inserting)) + (insert-character (value prefix-mark) #\-)) + + +;;; C-X U Unexpand Last Word +;;; Unexpands last abbrev or undoes last C-X U. + +(defcommand "Unexpand Last Word" (p) + "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\". + Only one abbrev may be undone." + "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\"." + (declare (ignore p)) + (unless (or (not (hemlock-bound-p 'last-expanded)) + (value last-expanded)) + (editor-error "Nothing to Undo.")) + (let ((mark (car (value last-expanded))) + (word1 (second (value last-expanded))) + (word2 (third (value last-expanded)))) + (unless (string= word2 + (region-to-string + (region (character-offset (copy-mark mark :temporary) + (- (length word2))) + mark))) + (editor-error "The last expanded Abbrev has been altered in the text.")) + (delete-characters mark (- (length word2))) + (insert-string mark word1) + (character-offset mark (length word1)) + (setf (value last-expanded) (list mark word2 word1)))) + + + +;;; Delete Mode Word Abbrev Kills some Mode abbrevs. + +(defcommand "Delete Mode Word Abbrev" + (p &optional abbrev + (mode (buffer-major-mode (current-buffer)))) + "Prompts for a word abbrev and deletes the mode expansion in the current mode. + If called with a prefix argument, deletes all word abbrevs define in the + current mode." + "Deletes Abbrev in Mode, or all abbrevs in Mode if P is true." + (let ((boundp (hemlock-bound-p 'Mode-Abbrev-Table :mode mode))) + (if p + (when boundp + (delete-variable 'Mode-Abbrev-Table :mode mode)) + (let ((down + (string-downcase + (or abbrev + (prompt-for-string + :prompt (list "~A abbrev to delete: " mode) + :help + (list "Give the name of a ~A mode word abbrev to delete." mode) + :trim t)))) + (table (and boundp (variable-value 'mode-abbrev-table :mode mode)))) + (unless (and table (gethash down table)) + (editor-error "~S is not the name of an abbrev in ~A mode." + down mode)) + (remhash down table))))) + + +;;; Delete Global Word Abbrevs Kills some Global abbrevs. + +(defcommand "Delete Global Word Abbrev" (p &optional abbrev) + "Prompts for a word abbrev and delete the global expansion. + If called with a prefix argument, deletes all global abbrevs." + "Deletes the global word abbreviation named Abbrev. If P is true, + deletes all global abbrevs." + (declare (ignore p)) + (if p + (setq *global-abbrev-table* (make-hash-table :test #'equal)) + (let ((down + (string-downcase + (or abbrev + (prompt-for-string + :prompt "Global abbrev to delete: " + :help "Give the name of a global word abbrev to delete." + :trim t))))) + (unless (gethash down *global-abbrev-table*) + (editor-error "~S is not the name of a global word abbrev." down)) + (remhash down *global-abbrev-table*)))) + +;;; Delete All Word Abbrevs Wipes them all. + +(defcommand "Delete All Word Abbrevs" (p) + "Deletes all currently defined Word Abbrevs" + "Deletes all currently defined Word Abbrevs" + (declare (ignore p)) + (Delete-Global-Word-Abbrev-Command 1) + (Delete-Mode-Word-Abbrev-Command 1)) + + +;;;; Abbrev I/O + +;;; List Word Abbrevs Shows definitions of all word abbrevs. + +(defcommand "List Word Abbrevs" (p) + "Lists all of the currently defined Word Abbrevs." + "Lists all of the currently defined Word Abbrevs." + (word-abbrev-apropos-command p "")) + + +;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev, +;;; definition, or mode. + +(defcommand "Word Abbrev Apropos" (p &optional search-string) + "Lists all of the currently defined Word Abbrevs which contain a given string + in their abbrev. definition, or mode." + "Lists all of the currently defined Word Abbrevs which contain a given string + in their abbrev. definition, or mode." + (declare (ignore p)) + (unless search-string + (setq search-string + (string-downcase + (prompt-for-string + :prompt "Apropos string: " + :help "The string to search word abbrevs and definitions for.")))) + (multiple-value-bind (count mode-tables) (count-abbrevs) + (with-pop-up-display (s :height (min (1+ count) 30)) + (unless (zerop (hash-table-count *global-abbrev-table*)) + (maphash #'(lambda (key val) + (when (or (search search-string (string-downcase key)) + (search search-string (string-downcase val))) + (write-abbrev key val nil s t))) + *global-abbrev-table*)) + (dolist (modename mode-tables) + (let ((table (variable-value 'Mode-Abbrev-Table :mode modename))) + (if (search search-string (string-downcase modename)) + (maphash #'(lambda (key val) + (write-abbrev key val modename s t)) + table) + (maphash #'(lambda (key val) + (when (or (search search-string (string-downcase key)) + (search search-string (string-downcase val))) + (write-abbrev key val modename s t))) + table)))) + (terpri s)))) + + + +(defun count-abbrevs () + (let* ((count (hash-table-count *global-abbrev-table*)) + (mode-tables nil)) + (do-strings (which x *mode-names*) + (declare (ignore x)) + (when (hemlock-bound-p 'Mode-Abbrev-Table :mode which) + (let ((table-count (hash-table-count (variable-value 'Mode-Abbrev-Table + :mode which)))) + (unless (zerop table-count) + (incf count table-count) + (push which mode-tables))))) + (values count mode-tables))) + + +;;; Edit Word Abbrevs Lets you edit the definition list directly. + +(defcommand "Edit Word Abbrevs" (p) + "Allows direct editing of currently defined Word Abbrevs." + "Allows direct editing of currently defined Word Abbrevs." + (declare (ignore p)) + (when (getstring "Edit Word Abbrevs" *buffer-names*) + (delete-buffer (getstring "Edit Word Abbrevs" *buffer-names*))) + (let ((old-buf (current-buffer)) + (new-buf (make-buffer "Edit Word Abbrevs"))) + (change-to-buffer new-buf) + (unwind-protect + (progn + (insert-word-abbrevs-command nil) + (do-recursive-edit) + (unless (equal #\newline (previous-character (buffer-end (current-point)))) + (insert-character (current-point) #\newline)) + (delete-all-word-abbrevs-command nil) + (define-word-abbrevs-command nil)) + (progn + (change-to-buffer old-buf) + (delete-buffer new-buf))))) + + + +;;; Insert Word Abbrevs Inserts a list of current definitions in the +;;; format that Define Word Abbrevs uses. + +(defcommand "Insert Word Abbrevs" (p) + "Inserts into the current buffer a list of all currently defined abbrevs in the + format used by \"Define Word Abbrevs\"." + "Inserts into the current buffer a list of all currently defined abbrevs in the + format used by \"Define Word Abbrevs\"." + + (declare (ignore p)) + (multiple-value-bind (x mode-tables) + (count-abbrevs) + (declare (ignore x)) + (with-output-to-mark (stream (current-point) :full) + (maphash #'(lambda (key val) + (write-abbrev key val nil stream)) + *global-abbrev-table*) + + (dolist (mode mode-tables) + (let ((modename (if (listp mode) (car mode) mode))) + (maphash #'(lambda (key val) + (write-abbrev key val modename stream)) + (variable-value 'Mode-Abbrev-Table :mode modename))))))) + + + +;;; Define Word Abbrevs Defines set of abbrevs from a definition list in +;;; the buffer. + +(defcommand "Define Word Abbrevs" (p) + "Defines Word Abbrevs from the definition list in the current buffer. The + definition list must be in the format produced by \"Insert Word Abbrevs\"." + "Defines Word Abbrevs from the definition list in the current buffer. The + definition list must be in the format produced by \"Insert Word Abbrevs\"." + + (declare (ignore p)) + (with-input-from-region (file (buffer-region (current-buffer))) + (read-abbrevs file))) + + +;;; Read Word Abbrev file <filename> Define word abbrevs from a definition file. + +;;; Ignores all lines less than 4 characters, i.e. blankspace or errors. That is +;;; the minimum number of characters possible to define an abbrev. It thinks the +;;; current abbrev "wraps" if there is no #\" at the end of the line or there are +;;; two #\"s at the end of the line (unless that is the entire definition string, +;;; i.e, a null-abbrev). + +;;; The format of the Abbrev files is +;;; +;;; ABBREV<tab><tab>"ABBREV DEFINITION" +;;; +;;; for Global Abbrevs, and +;;; +;;; ABBREV<tab>(MODE)<tab>"ABBREV DEFINITION" +;;; +;;; for Modal Abbrevs. +;;; Double-quotes contained within the abbrev definition are doubled. If the first +;;; line of an abbrev definition is not closed by a single double-quote, then +;;; the subsequent lines are read in until a single double-quote is found. + +(defcommand "Read Word Abbrev File" (p &optional filename) + "Reads in a file of previously defined abbrev definitions." + "Reads in a file of previously defined abbrev definitions." + (declare (ignore p)) + (setf (value abbrev-pathname-defaults) + (if filename + filename + (prompt-for-file + :prompt "Name of abbrev file: " + :help "The name of the abbrev file to load." + :default (value abbrev-pathname-defaults) + :must-exist nil))) + (with-open-file (file (value abbrev-pathname-defaults) :direction :input + :element-type 'string-char :if-does-not-exist :error) + (read-abbrevs file))) + + +;;; Does the actual defining of abbrevs from a given stream, expecting tabs and +;;; doubled double-quotes. + +(defun read-abbrevs (file) + (do ((line (read-line file nil nil) + (read-line file nil nil))) + ((null line)) + (unless (< (length line) 4) + (let* ((tab (position #\tab line)) + (tab2 (position #\tab line :start (1+ tab))) + (abbrev (subseq line 0 tab)) + (modename (subseq line (1+ tab) tab2)) + (expansion (do* ((last (1+ (position #\" line)) + (if found (min len (1+ found)) 0)) + (len (length line)) + (found (if (position #\" line :start last) + (1+ (position #\" line :start last))) + (if (position #\" line :start last) + (1+ (position #\" line :start last)))) + (expansion (subseq line last (if found found len)) + (concatenate 'simple-string expansion + (subseq line last + (if found found + len))))) + ((and (or (null found) (= found len)) + (equal #\" (char line (1- len))) + (or (not (equal #\" (char line (- len 2)))) + (= (- len 3) tab2))) + (subseq expansion 0 (1- (length expansion)))) + + (when (null found) + (setq line (read-line file nil nil) + last 0 + len (length line) + found (if (position #\" line) + (1+ (position #\" line))) + expansion (format nil "~A~%~A" expansion + (subseq line 0 (if found + found + 0)))))))) + + (cond ((equal modename "") + (setf (gethash abbrev *global-abbrev-table*) + expansion)) + (t (setq modename (subseq modename 1 (1- (length modename)))) + (unless (hemlock-bound-p 'Mode-Abbrev-Table + :mode modename) + (defhvar "Mode Abbrev Table" + "Hash Table of Mode Abbrevs" + :value (make-hash-table :test #'equal) + :mode modename)) + (setf (gethash abbrev (variable-value + 'Mode-Abbrev-Table :mode modename)) + expansion))))))) + + +;;; Write Word Abbrev File Make a definition file from current abbrevs. + +(defcommand "Write Word Abbrev File" (p &optional filename) + "Saves the currently defined Abbrevs to a file." + "Saves the currently defined Abbrevs to a file." + (declare (ignore p)) + (unless filename + (setq filename + (prompt-for-file + :prompt "Write abbrevs to file: " + :default (value abbrev-pathname-defaults) + :help "Name of the file to write current abbrevs to." + :must-exist nil))) + (with-open-file (file filename :direction :output + :element-type 'string-char :if-exists :supersede + :if-does-not-exist :create) + (multiple-value-bind (x mode-tables) (count-abbrevs) + (declare (ignore x)) + (maphash #'(lambda (key val) + (write-abbrev key val nil file)) + *global-abbrev-table*) + + (dolist (modename mode-tables) + (let ((mode (if (listp modename) (car modename) modename))) + (maphash #'(lambda (key val) + (write-abbrev key val mode file)) + (variable-value 'Mode-Abbrev-Table :mode mode)))))) + (let ((tn (truename filename))) + (setf (value abbrev-pathname-defaults) tn) + (message "~A written." (namestring tn)))) + + + +;;; Append to Word Abbrev File Appends to a file changed abbrev +;;; definitions since last dumping. + +(defcommand "Append to Word Abbrev File" (p &optional filename) + "Appends Abbrevs defined or redefined since the last save to a file." + "Appends Abbrevs defined or redefined since the last save to a file." + (declare (ignore p)) + (cond + (*new-abbrevs* + (unless filename + (setq filename + (prompt-for-file + :prompt + "Append incremental abbrevs to file: " + :default (value abbrev-pathname-defaults) + :must-exist nil + :help "Filename to append recently defined Abbrevs to."))) + (write-incremental :append filename)) + (t + (message "No Abbrev definitions have been changed since the last write.")))) + + +(defun write-incremental (mode filename) + (with-open-file (file filename :direction :output :element-type 'string-char + :if-exists mode :if-does-not-exist :create) + (dolist (def *new-abbrevs*) + (let ((abb (car def)) + (val (second def)) + (mode (third def))) + (write-abbrev abb val mode file)))) + (let ((tn (truename filename))) + (setq *new-abbrevs* nil) + (setf (value abbrev-pathname-defaults) tn) + (message "~A written." (namestring tn)))) + + +;;; Given an Abbrev, expansion, mode (nil for Global), and stream, this function +;;; writes to the stream with doubled double-quotes and stuff. +;;; If the flag is true, then the output is in a pretty format (like "List Word +;;; Abbrevs" uses), otherwise output is in tabbed format (like "Write Word +;;; Abbrev File" uses). + +(defun write-abbrev (abbrev expansion modename file &optional flag) + (if flag + (if modename + (format file "~5t~A~20t(~A)~35t\"" abbrev modename); pretty format + (format file "~5t~A~35t\"" abbrev)) ; pretty format + (cond (modename + (write-string abbrev file) + (write-char #\tab file) + (format file "(~A)" modename) ; "~A<tab>(~A)<tab>\"" + (write-char #\tab file) + (write-char #\" file)) + (t + (write-string abbrev file) + (write-char #\tab file) ; "~A<tab><tab>\"" + (write-char #\tab file) + (write-char #\" file)))) + (do* ((prev 0 found) + (found (position #\" expansion) + (position #\" expansion :start found))) + ((not found) + (write-string expansion file :start prev) + (write-char #\" file) + (terpri file)) + (incf found) + (write-string expansion file :start prev :end found) + (write-char #\" file))) + + +(defcommand "Abbrev Mode" (p) + "Put current buffer in Abbrev mode." + "Put current buffer in Abbrev mode." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Abbrev") + (not (buffer-minor-mode (current-buffer) "Abbrev")))) diff --git a/hemlock/bit-stream.lisp b/hemlock/bit-stream.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3aeebd36e8c0ea2779dda41d57cd824ac0a0e53d --- /dev/null +++ b/hemlock/bit-stream.lisp @@ -0,0 +1,146 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Some stuff to make streams that write out on bitmap hunks. +;;; +;;; Written by Rob MacLachlan. +;;; Modified by Bill Chiles to run under X on the IBM RT. +;;; +(in-package 'hemlock-internals) + + +;;; These streams have an associated bitmap-hunk that is used for its +;;; font-family, foreground and background color, and X window pointer. +;;; The hunk need not be associated with any Hemlock window, and the low +;;; level painting routines that use hunk dimensions are not used for +;;; output. Only BITMAP-HUNK-WRITE-STRING is used. The hunk is not +;;; registered for any event service, so resizing the associated X window +;;; does not invoke the exposed/changed handler in Bit-Screen.Lisp; also, the +;;; hunk's input and changed handler slots are not set. +;;; +(defstruct (bitmap-hunk-output-stream (:include stream + (out #'bitmap-hunk-out) + (sout #'bitmap-hunk-sout) + (misc #'bitmap-hunk-misc)) + (:constructor + make-bitmap-hunk-output-stream (hunk))) + hunk ; bitmap-hunk we display on. + (cursor-x 0) ; Character position of output cursor. + (cursor-y 0) + (buffer (make-string hunk-width-limit) :type simple-string) + (old-bottom 0)) ; # of lines of scrolling before next "--More--" prompt. + +;;; Bitmap-Hunk-Stream-Newline -- Internal +;;; +;;; Flush the stream's output buffer and then move the cursor down +;;; or scroll the window up if there is no room left. +;;; +(defun bitmap-hunk-stream-newline (stream) + (let* ((hunk (bitmap-hunk-output-stream-hunk stream)) + (height (bitmap-hunk-char-height hunk)) + (y (bitmap-hunk-output-stream-cursor-y stream))) + (when (zerop (bitmap-hunk-output-stream-old-bottom stream)) + (hunk-write-string hunk 0 y "--More--" 0 8) + (let ((device (device-hunk-device hunk))) + (when (device-force-output device) + (funcall (device-force-output device)))) + (wait-for-more) + (hunk-clear-lines hunk y 1) + (setf (bitmap-hunk-output-stream-old-bottom stream) (1- height))) + (hunk-write-string hunk 0 y (bitmap-hunk-output-stream-buffer stream) 0 + (bitmap-hunk-output-stream-cursor-x stream)) + (setf (bitmap-hunk-output-stream-cursor-x stream) 0) + (decf (bitmap-hunk-output-stream-old-bottom stream)) + (incf y) + (when (= y height) + (decf y) + (hunk-copy-lines hunk 1 0 y) + (hunk-clear-lines hunk y 1)) + (setf (bitmap-hunk-output-stream-cursor-y stream) y))) + +;;; Bitmap-Hunk-Misc -- Internal +;;; +;;; This is the misc method for bitmap-hunk-output-streams. It just +;;; writes out the contents of the buffer, and does the element type. +;;; +(defun bitmap-hunk-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:charpos + (values (bitmap-hunk-output-stream-cursor-x stream) + (bitmap-hunk-output-stream-cursor-y stream))) + ((:finish-output :force-output) + (hunk-write-string (bitmap-hunk-output-stream-hunk stream) + 0 (bitmap-hunk-output-stream-cursor-y stream) + (bitmap-hunk-output-stream-buffer stream) 0 + (bitmap-hunk-output-stream-cursor-x stream)) + (let ((device (device-hunk-device (bitmap-hunk-output-stream-hunk stream)))) + (when (device-force-output device) + (funcall (device-force-output device))))) + (:line-length + (bitmap-hunk-char-width (bitmap-hunk-output-stream-hunk stream))) + (:element-type 'string-char))) + + +;;; Bitmap-Hunk-Out -- Internal +;;; +;;; Throw a character in a bitmap-hunk-stream's buffer. If we wrap or hit a +;;; newline then call bitmap-hunk-stream-newline. +;;; +(defun bitmap-hunk-out (stream character) + (let ((hunk (bitmap-hunk-output-stream-hunk stream)) + (x (bitmap-hunk-output-stream-cursor-x stream))) + (cond ((char= character #\newline) + (bitmap-hunk-stream-newline stream) + (return-from bitmap-hunk-out nil)) + ((= x (bitmap-hunk-char-width hunk)) + (setq x 0) + (bitmap-hunk-stream-newline stream))) + (setf (schar (bitmap-hunk-output-stream-buffer stream) x) character) + (setf (bitmap-hunk-output-stream-cursor-x stream) (1+ x)))) + + +;;; Bitmap-Hunk-Sout -- Internal +;;; +;;; Write a string out to a bitmap-hunk, calling ourself recursively if the +;;; string contains newlines. +;;; +(defun bitmap-hunk-sout (stream string start end) + (let* ((hunk (bitmap-hunk-output-stream-hunk stream)) + (buffer (bitmap-hunk-output-stream-buffer stream)) + (x (bitmap-hunk-output-stream-cursor-x stream)) + (dst-end (+ x (- end start))) + (width (bitmap-hunk-char-width hunk))) + (cond ((%primitive find-character string start end #\newline) + (do ((current (%primitive find-character string start end #\newline) + (%primitive find-character string (1+ current) + end #\newline)) + (previous start (1+ current))) + ((null current) + (bitmap-hunk-sout stream string previous end)) + (bitmap-hunk-sout stream string previous current) + (bitmap-hunk-stream-newline stream))) + ((> dst-end width) + (let ((new-start (+ start (- width x)))) + (%primitive byte-blt string start buffer x width) + (setf (bitmap-hunk-output-stream-cursor-x stream) width) + (bitmap-hunk-stream-newline stream) + (do ((idx (+ new-start width) (+ idx width)) + (prev new-start idx)) + ((>= idx end) + (let ((dst-end (- end prev))) + (%primitive byte-blt string prev buffer 0 dst-end) + (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end))) + (%primitive byte-blt string prev buffer 0 width) + (setf (bitmap-hunk-output-stream-cursor-x stream) width) + (bitmap-hunk-stream-newline stream)))) + (t + (%primitive byte-blt string start buffer x dst-end) + (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end))))) diff --git a/hemlock/charmacs.lisp b/hemlock/charmacs.lisp new file mode 100644 index 0000000000000000000000000000000000000000..204fc109c72a4eead84f86196928858e1c2dd9db --- /dev/null +++ b/hemlock/charmacs.lisp @@ -0,0 +1,204 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Implementation specific character-hacking macros and constants. +;;; +(in-package 'hemlock-internals) +(export ' (syntax-char-code-limit command-char-bits-limit + command-char-code-limit search-char-code-limit + do-alpha-chars)) + +;;; This file contains various constants and macros which are +;;; implementation or ASCII dependant. In particular it contains +;;; all the character implementation parameters such as +;;; Command-Char-Bits-Limit, and contains various versions +;;; of char-code which don't check types and omit the top bit +;;; so that various structures can be allocated 128 long instead +;;; of 256, and we don't get errors if a loser visits a binary file. + +;;; There are so many different constants and macros that do the same +;;; thing because in principle the char-code-limit for the syntax +;;; functions is independant of that for the searching functions, etc. + +;;; This file also contains code which adds any implementation specific +;;; character names to the char file's Char-Name-Alist so that there +;;; is a reasonable read-syntax and print-representation for all +;;; characters a user might run across. + + +;;; All the meaningful bit names in this implementation. +;;; +(defconstant all-bit-names '(:control :meta :super :hyper)) + + +;;;; Stuff for the Syntax table functions (syntax) +;;; +(defconstant syntax-char-code-limit 128 + "The highest char-code which a character argument to the syntax + table functions may have.") +(defconstant syntax-char-code-mask #x+7f + "Mask we AND with characters given to syntax table functions to blow away + bits we don't want.") +(defmacro syntax-char-code (char) + `(logand syntax-char-code-mask (lisp::%sp-make-fixnum ,char))) + +;;;; Stuff for the command interpreter (interp) +;;; +;;; On the Perq we have bits for command bindings, on the VAX there +;;; aren't. The code to interpret them is conditionally compiled +;;; so that the VAX isnt't slowed down. +;;; +;;; Make command-char-code-limit 256 instead of 128 for X keyboard scan-codes. +(defconstant command-char-code-limit 256 + "The upper bound on character codes supported for key bindings.") +(defconstant command-char-bits-limit 16 + "The maximum value of character bits supported for key bindings.") +(defmacro key-char-bits (char) + `(ash (logand #x+F00 (lisp::%sp-make-fixnum ,char)) -8)) +(defmacro key-char-code (char) + `(char-code ,char)) +;;; `(logand #x+7f (lisp::%sp-make-fixnum ,char))) can't use with X scan-codes. + + +;;;; Stuff used by the searching primitives (search) +;;; +(defconstant search-char-code-limit 128 + "The exclusive upper bound on significant char-codes for searching.") +(defmacro search-char-code (ch) + `(logand (lisp::%sp-make-fixnum ,ch) #x+7F)) +;;; +;;; search-hash-code must be a function with the following properties: +;;; given any character it returns a number between 0 and +;;; search-char-code-limit, and the same hash code must be returned +;;; for the upper and lower case forms of each character. +;;; In ASCII this is can be done by ANDing out the 5'th bit. +;;; +(defmacro search-hash-code (ch) + `(logand (lisp::%sp-make-fixnum ,ch) #x+5F)) + +;;; Doesn't do anything special, but it should fast and not waste any time +;;; checking type and whatnot. +(defmacro search-char-upcase (ch) + `(lisp::fast-char-upcase ,ch)) + + +;;; Specal RT and Sun keys: + +(eval-when (compile load eval) + +(push (cons "DELETE" #\delete) lisp::char-name-alist) +(push (cons "ESCAPE" #\escape) lisp::char-name-alist) +(push (cons "F1" (code-char 1)) lisp::char-name-alist) +(push (cons "F2" (code-char 2)) lisp::char-name-alist) +(push (cons "F3" (code-char 3)) lisp::char-name-alist) +(push (cons "F4" (code-char 4)) lisp::char-name-alist) +(push (cons "F5" (code-char 5)) lisp::char-name-alist) +(push (cons "F6" (code-char 6)) lisp::char-name-alist) +(push (cons "F7" (code-char 7)) lisp::char-name-alist) +(push (cons "F8" (code-char 11)) lisp::char-name-alist) +(push (cons "F9" (code-char 12)) lisp::char-name-alist) +(push (cons "F10" (code-char 14)) lisp::char-name-alist) +(push (cons "F11" (code-char 17)) lisp::char-name-alist) +(push (cons "F12" (code-char 18)) lisp::char-name-alist) +(push (cons "LEFTARROW" (code-char 19)) lisp::char-name-alist) +(push (cons "RIGHTARROW" (code-char 20)) lisp::char-name-alist) +(push (cons "UPARROW" (code-char 22)) lisp::char-name-alist) +(push (cons "DOWNARROW" (code-char 23)) lisp::char-name-alist) +(push (cons "LEFTDOWN" (code-char 24)) lisp::char-name-alist) +(push (cons "MIDDLEDOWN" (code-char 25)) lisp::char-name-alist) +(push (cons "RIGHTDOWN" (code-char 128)) lisp::char-name-alist) +(push (cons "LEFTUP" (code-char 129)) lisp::char-name-alist) +(push (cons "MIDDLEUP" (code-char 130)) lisp::char-name-alist) +(push (cons "RIGHTUP" (code-char 131)) lisp::char-name-alist) +(push (cons "INSERT" (code-char 132)) lisp::char-name-alist) +(push (cons "PRINTSCREEN" (code-char 133)) lisp::char-name-alist) +(push (cons "PAUSE" (code-char 134)) lisp::char-name-alist) +(push (cons "HOME" (code-char 135)) lisp::char-name-alist) +(push (cons "END" (code-char 136)) lisp::char-name-alist) +(push (cons "PAGEUP" (code-char 137)) lisp::char-name-alist) +(push (cons "PAGEDOWN" (code-char 138)) lisp::char-name-alist) +(push (cons "NUMLOCK" (code-char 139)) lisp::char-name-alist) +(push (cons "F13" (code-char 140)) lisp::char-name-alist) +(push (cons "F14" (code-char 141)) lisp::char-name-alist) +(push (cons "F15" (code-char 142)) lisp::char-name-alist) +(push (cons "F16" (code-char 143)) lisp::char-name-alist) +(push (cons "F17" (code-char 144)) lisp::char-name-alist) +(push (cons "F18" (code-char 145)) lisp::char-name-alist) +(push (cons "F19" (code-char 146)) lisp::char-name-alist) +(push (cons "F20" (code-char 147)) lisp::char-name-alist) +(push (cons "F21" (code-char 148)) lisp::char-name-alist) +(push (cons "F22" (code-char 149)) lisp::char-name-alist) +(push (cons "F23" (code-char 150)) lisp::char-name-alist) +(push (cons "F24" (code-char 151)) lisp::char-name-alist) +(push (cons "F25" (code-char 152)) lisp::char-name-alist) +(push (cons "F26" (code-char 153)) lisp::char-name-alist) +(push (cons "F27" (code-char 154)) lisp::char-name-alist) +(push (cons "F28" (code-char 155)) lisp::char-name-alist) +(push (cons "F29" (code-char 156)) lisp::char-name-alist) +(push (cons "F30" (code-char 157)) lisp::char-name-alist) +(push (cons "F31" (code-char 158)) lisp::char-name-alist) +(push (cons "F32" (code-char 159)) lisp::char-name-alist) +(push (cons "F33" (code-char 160)) lisp::char-name-alist) +(push (cons "F34" (code-char 161)) lisp::char-name-alist) +(push (cons "F35" (code-char 162)) lisp::char-name-alist) +;; ALTERNATE key on Sun keyboard. +(push (cons "BREAK" (code-char 163)) lisp::char-name-alist) + +) ;eval-when (compile load eval) + +;;; Stick them on the end so that they don't print this way. +;;; Use two separate EVAL-WHEN forms, so the #\f<13-35> characters can be +;;; read at this point. +;;; +(eval-when (compile load eval) +(setq lisp::char-name-alist + (append lisp::char-name-alist + '(("ENTER" . #\return) ("ACTION" . #\linefeed) + + ("L1" . #\F11) ("L2" . #\F12) ("L3" . #\F13) ("L4" . #\F14) + ("L5" . #\F15) ("L6" . #\F16) ("L7" . #\F17) ("L8" . #\F18) + ("L9" . #\F19) ("L10" . #\F20) + + ("R1" . #\F21) ("R2" . #\F22) ("R3" . #\F23) ("R4" . #\F24) + ("R5" . #\F25) ("R6" . #\F26) ("R7" . #\F27) ("R8" . #\F28) + ("R9" . #\F29) ("R10" . #\F30) ("R11" . #\F31) ("R12" . #\F32) + ("R13" . #\F33) ("R14" . #\F34) ("R15" . #\F35)))) +) ;eval-when + + +;;; ALPHA-CHARS-LOOP loops from start-char through end-char binding var +;;; to the alphabetic characters and executing body. Note that the manual +;;; guarantees lower and upper case char codes to be separately in order, +;;; but other characters may be interspersed within that ordering. +(defmacro alpha-chars-loop (var start-char end-char result body) + (let ((n (gensym)) + (end-char-code (gensym))) + `(do ((,n (char-code ,start-char) (1+ ,n)) + (,end-char-code (char-code ,end-char))) + ((> ,n ,end-char-code) ,result) + (let ((,var (code-char ,n))) + (when (alpha-char-p ,var) + ,@body))))) + +(defmacro do-alpha-chars ((var kind &optional result) &rest forms) + "(do-alpha-chars (var kind [result]) . body). Kind is one of + :lower, :upper, or :both, and var is bound to each character in + order as specified under character relations in the manual. When + :both is specified, lowercase letters are processed first." + (case kind + (:both + `(progn (alpha-chars-loop ,var #\a #\z nil ,forms) + (alpha-chars-loop ,var #\A #\Z ,result ,forms))) + (:lower + `(alpha-chars-loop ,var #\a #\z ,result ,forms)) + (:upper + `(alpha-chars-loop ,var #\A #\Z ,result ,forms)) + (t (error "Kind argument not one of :lower, :upper, or :both -- ~S." + kind)))) diff --git a/hemlock/cursor.lisp b/hemlock/cursor.lisp new file mode 100644 index 0000000000000000000000000000000000000000..d90265bd5838f505295908179fa2eb7153024384 --- /dev/null +++ b/hemlock/cursor.lisp @@ -0,0 +1,409 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; +;;; Cursor: Routines for cursor positioning and recentering +;;; +(in-package 'hemlock-internals) +(export '(mark-to-cursorpos center-window displayed-p scroll-window + mark-column cursorpos-to-mark move-to-column)) + + +;;;; Mark-To-Cursorpos +;;; +;;; Since performance analysis showed that HALF of the time in the editor +;;; was being spent in this function, I threw all of the tricks in the +;;; book at it to try and make it tenser. +;;; +;;; The algorithm is roughly as follows: +;;; +;;; 1) Eliminate the annoying boundry condition of the mark being +;;; off the end of the window, if it is return NIL now. +;;; 2) If the charpos is on or immediately after the last character +;;; in the line, then find the last dis-line on which the line is +;;; displayed. We know that the mark is at the end of this dis-line +;;; because it is known to be on the screen. X position is trivially +;;; derived from the dis-line-length. +;;; 3) Call Real-Line-Length or Cached-Real-Line-Length to get the +;;; X position and number of times wrapped. + +(proclaim '(special the-sentinel)) + +(eval-when (compile eval) +;;; find-line +;;; +;;; Find a dis-line which line is displayed on which starts before +;;; charpos, setting ypos and dis-line to the dis-line and it's index. +;;; Offset is expected to be the mark-charpos of the display-start for +;;; the window initially, and is set to offset within line that +;;; Dis-Line begins. Charpos is the mark-charpos of the mark we want +;;; to find. Check if same as *redisplay-favorite-line* and then scan +;;; if not. +;;; +(defmacro find-line (line offset charpos ypos dis-lines dis-line) + `(cond + ;; No lines at all, fail. + ((eq ,dis-lines the-sentinel) nil) + ;; On the first line, offset is already set, so just set dis-line and + ;; ypos and fall through. + ((eq (dis-line-line (car ,dis-lines)) ,line) + (setq ,dis-line ,dis-lines ,ypos 0)) + ;; Look farther down. + ((do ((l (cdr ,dis-lines) (cdr l))) + ((eq l the-sentinel)) + (when (eq (dis-line-line (car l)) ,line) + (setq ,dis-line l ,ypos (dis-line-position (car l)) ,offset 0) + (return t)))) + (t + (error "Horrible flaming lossage, Sorry Man.")))) + +;;; find-last +;;; +;;; Find the last dis-line on which line is displayed, set ypos and +;;; dis-line. +;;; +(defmacro find-last (line ypos dis-line) + `(do ((trail ,dis-line dl) + (dl (cdr ,dis-line) (cdr dl))) + ((not (eq (dis-line-line (car dl)) ,line)) + (setq ,dis-line (car trail) ,ypos (dis-line-position ,dis-line))))) + +;;; find-charpos +;;; +;;; Special-Case mark at end of line, if not punt out to real-line-length +;;; function. Return the correct values. +;;; +(defmacro find-charpos (line offset charpos length ypos dis-line width + fun chars) + `(cond + ((= ,charpos ,length) + (find-last ,line ,ypos ,dis-line) + (values (min (dis-line-length ,dis-line) (1- ,width)) ,ypos)) + ((= ,charpos (1- ,length)) + (multiple-value-bind (x dy) + (,fun ,line (1- ,width) ,offset ,charpos) + (if (and (not (zerop dy)) (zerop x)) + (values (1- ,width) (1- (+ ,ypos dy))) + (values x (+ ,ypos dy))))) + (t + (multiple-value-bind (x dy) + (,fun ,line (1- ,width) ,offset ,charpos) + (values x (+ ,ypos dy)))))) + +); eval-when (compile eval) + +;;; real-line-length +;;; +;;; Return as values the X position and the number of times wrapped if +;;; one to display the characters from Start to End of Line starting at an +;;; X position of 0 wrapping Width wide. +;;; %SP-Find-Character-With-Attribute is used to find charaters +;;; with funny representation much as in Compute-Line-Image. +;;; +(defun real-line-length (line width start end) + (declare (fixnum width start end)) + (do ((xpos 0) + (ypos 0) + (chars (line-chars line)) losing dy) + ((= start end) (values xpos ypos)) + (declare (fixnum xpos ypos losing dy) (simple-string chars)) + (setq losing (%fcwa chars start end losing-char)) + (when (null losing) + (multiple-value-setq (dy xpos) (truncate (+ xpos (- end start)) width)) + (return (values xpos (+ ypos dy)))) + (multiple-value-setq (dy xpos) (truncate (+ xpos (- losing start)) width)) + (setq ypos (+ ypos dy) start losing) + (do ((last (or (%fcwa chars start end winning-char) end)) str) + ((= start last)) + (declare (fixnum last)) + (setq str (get-rep (schar chars start))) + (incf start) + (unless (simple-string-p str) (setq str (funcall str xpos))) + (multiple-value-setq (dy xpos) (truncate (+ xpos (strlen str)) width)) + (setq ypos (+ ypos dy))))) + +;;; cached-real-line-length +;;; +;;; The same as Real-Line-Length, except does it for the cached line. +;;; the line argument is ignored, but present to make the arglists the +;;; same. +;;; +(defun cached-real-line-length (line width start end) + (declare (fixnum width start end) (ignore line)) + (let ((offset (- right-open-pos left-open-pos)) bound) + (declare (fixnum offset bound)) + (cond + ((>= start left-open-pos) + (setq start (+ start offset) bound (setq end (+ end offset)))) + ((> end left-open-pos) + (setq bound left-open-pos end (+ end offset))) + (t + (setq bound end))) + + (do ((xpos 0) + (ypos 0) losing dy) + (()) + (declare (fixnum xpos ypos losing dy)) + (when (= start bound) + (when (= start end) (return (values xpos ypos))) + (setq start right-open-pos bound end)) + (setq losing (%fcwa open-chars start bound losing-char)) + (cond + (losing + (multiple-value-setq (dy xpos) + (truncate (+ xpos (- losing start)) width)) + (setq ypos (+ ypos dy) start losing) + (do ((last (or (%fcwa open-chars start bound winning-char) bound)) str) + ((= start last)) + (declare (fixnum last)) + (setq str (get-rep (schar open-chars start))) + (incf start) + (unless (simple-string-p str) (setq str (funcall str xpos))) + (multiple-value-setq (dy xpos) + (truncate (+ xpos (strlen str)) width)) + (setq ypos (+ ypos dy)))) + (t + (multiple-value-setq (dy xpos) + (truncate (+ xpos (- bound start)) width)) + (setq ypos (+ ypos dy) start bound)))))) + +;;; mark-to-cursorpos -- Public +;;; +;;; Return as multiple values the x and y position within window of +;;; mark. NIL is returned if the mark is not displayed in the window given +;;; +;;; +(defun mark-to-cursorpos (mark window) + "Return the (x, y) position of mark within window, or NIL if not displayed." + (let* ((line (mark-line mark)) + (number (line-number line)) + (charpos (mark-charpos mark)) + (dis-lines (cdr (window-first-line window))) + (width (window-width window)) + (start (window-display-start window)) + (offset (mark-charpos start)) + (start-number (line-number (mark-line start))) + (end (window-display-end window)) + (end-number (line-number (mark-line end))) ypos dis-line) + (declare (fixnum width charpos ypos number end-number) + (simple-vector dis-lines)) + (cond + ((or (< number start-number) + (and (= number start-number) (< charpos offset)) + (> number end-number) + (and (= number end-number) (> charpos (mark-charpos end)))) nil) + (t + (find-line line offset charpos ypos dis-lines dis-line) + (cond + ((eq line open-line) + (let ((len (- line-cache-length (- right-open-pos left-open-pos)))) + (declare (fixnum len)) + (find-charpos line offset charpos len ypos dis-line width + cached-real-line-length open-chars))) + (t + (let* ((chars (line-chars line)) + (len (strlen chars))) + (declare (fixnum len) (simple-string chars)) + (find-charpos line offset charpos len ypos dis-line width + real-line-length chars)))))))) + +;;; Dis-Line-Offset-Guess -- Internal +;;; +;;; Move Mark by Offset display lines. The mark is assumed to be at the +;;; beginning of a display line, and we attempt to leave it at one. We assume +;;; all characters print one wide. Width is the width of the window we are +;;; displaying in. +;;; +(defun dis-line-offset-guess (mark offset width) + (let ((w (1- width))) + (if (minusp offset) + (dotimes (i (- offset) t) + (let ((pos (mark-charpos mark))) + (if (>= pos w) + (character-offset mark (- w)) + (let ((prev (line-previous (mark-line mark)))) + (unless prev (return nil)) + (multiple-value-bind + (lines chars) + (truncate (line-length prev) w) + (move-to-position mark + (cond ((zerop lines) 0) + ((< chars 2) + (* w (1- lines))) + (t + (* w lines))) + prev)))))) + (dotimes (i offset t) + (let ((left (- (line-length (mark-line mark)) + (mark-charpos mark)))) + (if (> left width) + (character-offset mark w) + (unless (line-offset mark 1 0) + (return nil)))))))) + +;;; maybe-recenter-window -- Internal +;;; +;;; Update the dis-lines for Window and recenter if the point is off +;;; the screen. +;;; +(defun maybe-recenter-window (window) + (unless (%displayed-p (buffer-point (window-buffer window)) window) + (center-window window (buffer-point (window-buffer window))) + t)) + +;;; center-window -- Public +;;; +;;; Try to move the start of window so that Mark is on a line in the +;;; center. +;;; +(defun center-window (window mark) + "Adjust the start of Window so that Mark is displayed on the center line." + (let ((height (window-height window)) + (start (window-display-start window))) + (move-mark start mark) + (unless (dis-line-offset-guess start (- (truncate height 2)) + (window-width window)) + (move-mark start (buffer-start-mark (window-buffer window)))) + (update-window-image window) + ;; If that doesn't work, panic and make the start the point. + (unless (%displayed-p mark window) + (move-mark start mark) + (update-window-image window)))) + + +;;; %Displayed-P -- Internal +;;; +;;; If Mark is within the displayed bounds in Window, then return true, +;;; otherwise false. We assume the window image is up to date. +;;; +(defun %displayed-p (mark window) + (let ((start (window-display-start window)) + (end (window-display-end window))) + (not (or (mark< mark start) (mark> mark end) + (if (mark= mark end) + (let ((ch (next-character end))) + (and ch (char/= ch #\newline))) + nil))))) + + +;;; Displayed-p -- Public +;;; +;;; Update the window image and then check if the mark is displayed. +;;; +(defun displayed-p (mark window) + "Return true if Mark is displayed on Window, false otherwise." + (update-window-image window) + (%displayed-p mark window)) + + +;;; scroll-window -- Public +;;; +;;; This is not really right, since it uses dis-line-offset-guess. +;;; Probably if there is any screen overlap then we figure it out +;;; exactly. +;;; +(defun scroll-window (window n) + "Scroll Window down N lines, up if negative." + (let ((start (window-display-start window)) + (point (window-point window)) + (width (window-width window)) + (height (window-height window))) + (cond ((dis-line-offset-guess start n width)) + ((minusp n) + (buffer-start start)) + (t + (buffer-end start) + (let ((fraction (- (truncate height 3) height))) + (dis-line-offset-guess start fraction width)))) + (update-window-image window) + (let ((iscurrent (eq window *current-window*)) + (bpoint (buffer-point (window-buffer window)))) + (when iscurrent (move-mark point bpoint)) + (unless (%displayed-p point window) + (move-mark point start) + (dis-line-offset-guess point (truncate (window-height window) 2) + width) + (when iscurrent (move-mark bpoint point))))) + t) + +;;; Mark-Column -- Public +;;; +;;; Find the X position of a mark supposing that it were displayed +;;; in an infinitely wide screen. +;;; +(defun mark-column (mark) + "Find the X position at which Mark would be displayed if it were on + an infinitely wide screen. This takes into account tabs and control + characters." + (let ((charpos (mark-charpos mark)) + (line (mark-line mark))) + (if (eq line open-line) + (values (cached-real-line-length line 10000 0 charpos)) + (values (real-line-length line 10000 0 charpos))))) + +;;; Find-Position -- Internal +;;; +;;; Return the charpos which corresponds to the specified X position +;;; within Line. If there is no such position between Start and End then +;;; rutne NIL. +;;; +(defun find-position (line position start end width) + (do* ((cached (eq line open-line)) + (lo start) + (hi (1- end)) + (probe (truncate (+ lo hi) 2) (truncate (+ lo hi) 2))) + ((> lo hi) + (if (= lo end) nil hi)) + (let ((val (if cached + (cached-real-line-length line width start probe) + (real-line-length line width start probe)))) + (cond ((= val position) (return probe)) + ((< val position) (setq lo (1+ probe))) + (t (setq hi (1- probe))))))) + +;;; Cursorpos-To-Mark -- Public +;;; +;;; Find the right dis-line, then zero in on the correct position +;;; using real-line-length. +;;; +(defun cursorpos-to-mark (x y window) + (check-type window window) + (let ((width (window-width window)) + (first (window-first-line window))) + (when (>= x width) + (return-from cursorpos-to-mark nil)) + (do* ((prev first dl) + (dl (cdr first) (cdr dl)) + (ppos (mark-charpos (window-display-start window)) + (if (eq (dis-line-line (car dl)) (dis-line-line (car prev))) + (dis-line-end (car prev)) 0))) + ((eq dl the-sentinel) + (copy-mark (window-display-end window) :temporary)) + (when (= (dis-line-position (car dl)) y) + (let* ((line (dis-line-line (car dl))) + (end (dis-line-end (car dl)))) + (return (mark line (or (find-position line x ppos end width) end)))))))) + +;;; Move-To-Column -- Public +;;; +;;; Just look up the charpos using find-position... +;;; +(defun move-to-column (mark column &optional (line (mark-line mark))) + "Move Mark to the specified Column on Line. This function is analogous + to Move-To-Position, but it deals with the physical screen position + as returned by Mark-Column; the mark is moved to before the character + which would be displayed in Column if the line were displayed on + an infinitely wide screen. If the column specified is greater than + the column of the last character, then Nil is returned and the mark + is not modified." + (let ((res (find-position line column 0 (line-length line) 10000))) + (if res + (move-to-position mark res line)))) diff --git a/hemlock/dired.lisp b/hemlock/dired.lisp new file mode 100644 index 0000000000000000000000000000000000000000..2ae2b8ea81a100ee21741b57428363e31401298e --- /dev/null +++ b/hemlock/dired.lisp @@ -0,0 +1,691 @@ +;;; -*- Log: hemlock.log; Package: dired -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains site dependent code for dired. +;;; Written by Bill Chiles. +;;; + +(in-package "DIRED") + +(shadow '(rename-file delete-file)) + +(export '(copy-file rename-file find-file delete-file make-directory + *update-default* *clobber-default* *recursive-default* + *report-function* *error-function* *yesp-function* + pathnames-from-pattern)) + + + +;;;; Exported parameters. + +(defparameter *update-default* nil + "Update arguments to utilities default to this value.") + +(defparameter *clobber-default* t + "Clobber arguments to utilities default to this value.") + +(defparameter *recursive-default* nil + "Recursive arguments to utilities default to this value.") + + + +;;;; WILDCARDP + +(defconstant wildcard-char #\* + "Wildcard designator for file names will match any substring.") + +(defmacro wildcardp (file-namestring) + `(position wildcard-char (the simple-string ,file-namestring) :test #'char=)) + + + +;;;; User interaction functions, variable declarations, and their defaults. + +(defun default-error-function (string &rest args) + (apply #'error string args)) +;;; +(defvar *error-function* #'default-error-function + "This function is called when an error is encountered in dired code.") + +(defun default-report-function (string &rest args) + (apply #'format t string args)) +;;; +(defvar *report-function* #'default-report-function + "This function is called when the user needs to be informed of something.") + +(defun default-yesp-function (string &rest args) + (apply #'format t string args) + (let ((answer (nstring-downcase (string-trim '(#\space #\tab) (read-line))))) + (declare (simple-string answer)) + (or (string= answer "") + (string= answer "y") + (string= answer "yes") + (string= answer "ye")))) +;;; +(defvar *yesp-function* #'default-yesp-function + "Function to query the user about clobbering an already existent file.") + + + +;;;; Copy-File + +;;; WILD-MATCH objects contain information about wildcard matches. File is the +;;; Sesame namestring of the file matched, and substitute is a substring of the +;;; file-namestring of file. +;;; +(defstruct (wild-match (:print-function print-wild-match) + (:constructor make-wild-match (file substitute))) + file + substitute) + +(defun print-wild-match (obj str n) + (declare (ignore n)) + (format str "#<Wild-Match ~S ~S>" + (wild-match-file obj) (wild-match-substitute obj))) + + +(defun copy-file (spec1 spec2 &key (update *update-default*) + (clobber *clobber-default*) + (directory () directoryp)) + "Copy file spec1 to spec2. A single wildcard is acceptable, and directory + names may be used. If spec1 and spec2 are both directories, then a + recursive copy is done of the files and subdirectory structure of spec1; + if spec2 is in the subdirectory structure of spec1, the recursion will + not descend into it. Use spec1/* to copy only the files in spec1 to + directory spec2. If spec2 is a directory, and spec1 is a file, then + spec1 is copied into spec2 with the same pathname-name. Files are + copied maintaining the source's write date. If :update is non-nil, then + files are only copied if the source is newer than the destination, still + maintaining the source's write date; the user is not warned if the + destination is newer (not the same write date) than the source. If + :clobber and :update are nil, then if any file spec2 already exists, the + user will be asked whether it should be overwritten or not." + (cond + ((not directoryp) + (multiple-value-bind (ses-name1 exists1p) + (lisp::predict-name spec1 t) + (let* ((ses-name2 (lisp::predict-name spec2 nil)) + (pname1 (pathname ses-name1)) + (pname2 (pathname ses-name2)) + (dirp1 (directoryp pname1)) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp (file-namestring pname1))) + (wildp2 (wildcardp (file-namestring pname2)))) + (when (and dirp1 wildp1) + (funcall *error-function* + "Cannot have wildcards in directory names -- ~S." pname1)) + (when (and dirp2 wildp2) + (funcall *error-function* + "Cannot have wildcards in directory names -- ~S." pname2)) + (when (and dirp1 (not dirp2)) + (funcall *error-function* + "Cannot handle spec1 being a directory and spec2 a file.")) + (when (and wildp2 (not wildp1)) + (funcall *error-function* + "Cannot handle destination having wildcards without ~ + source having wildcards.")) + (when (and wildp1 (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (cond ((and dirp1 dirp2) + (unless (directory-existsp ses-name1) + (funcall *error-function* + "Directory does not exist -- ~S." pname1)) + (unless (directory-existsp ses-name2) + (enter-directory ses-name2)) + (recursive-copy pname1 pname2 update clobber pname2 + ses-name1 ses-name2)) + (dirp2 + ;; merge pname2 with pname1 to pick up a similar file-namestring. + (copy-file-1 pname1 wildp1 exists1p + (merge-pathnames pname2 pname1) + wildp1 update clobber)) + (t (copy-file-1 pname1 wildp1 exists1p + pname2 wildp2 update clobber)))))) + (directory + (when (pathname-directory spec1) + (funcall *error-function* + "Spec1 is just a pattern when supplying directory -- ~S." + spec1)) + (let* ((pname2 (pathname (lisp::predict-name spec2 nil))) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp spec1)) + (wildp2 (wildcardp (file-namestring pname2)))) + (unless wildp1 + (funcall *error-function* + "Pattern, ~S, does not contain a wildcard." + spec1)) + (when (and (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (copy-wildcard-files spec1 wildp1 + (if dirp2 (merge-pathnames pname2 spec1) pname2) + (if dirp2 wildp1 wildp2) + update clobber directory)))) + (values)) + +;;; RECURSIVE-COPY takes two pathnames that represent directories, and +;;; the files in pname1 are copied into pname2, recursively descending into +;;; subdirectories. If a subdirectory of pname1 does not exist in pname2, +;;; it is created. Pname1 is known to exist. Forbidden-dir is originally +;;; the same as pname2; this keeps us from infinitely recursing if pname2 +;;; is in the subdirectory structure of pname1. Returns t if some file gets +;;; copied. +;;; +(defun recursive-copy (pname1 pname2 update clobber + forbidden-dir ses-name1 ses-name2) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2) + (dolist (spec (directory (directory-namestring pname1))) + (let ((spec-ses-name (namestring spec))) + (if (directoryp spec) + (unless (equal (pathname spec-ses-name) forbidden-dir) + (let* ((dir2-pname (merge-dirs spec pname2)) + (dir2-ses-name (namestring dir2-pname))) + (unless (directory-existsp dir2-ses-name) + (enter-directory dir2-ses-name)) + (recursive-copy spec dir2-pname update clobber forbidden-dir + spec-ses-name dir2-ses-name) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 + ses-name2))) + (copy-file-2 spec-ses-name + (namestring (merge-pathnames pname2 spec)) + update clobber))))) + +;;; MERGE-DIRS picks out the last directory name in the pathname pname1 and +;;; adds it to the end of the sequence of directory names from pname2, returning +;;; a pathname. +;;; +(defun merge-dirs (pname1 pname2) + (let* ((dirs1 (pathname-directory pname1)) + (dirs2 (pathname-directory pname2)) + (dirs2-len (length dirs2)) + (new-dirs2 (make-array (1+ dirs2-len)))) + (declare (simple-vector dirs1 dirs2 new-dirs2)) + (replace new-dirs2 dirs2) + (setf (svref new-dirs2 dirs2-len) + (svref dirs1 (1- (length dirs1)))) + (make-pathname :directory new-dirs2 :device :absolute))) + +;;; COPY-FILE-1 takes pathnames which either both contain a single wildcard +;;; or none. Wildp1 and Wildp2 are either nil or indexes into the +;;; file-namestring of pname1 and pname2, respectively, indicating the position +;;; of the wildcard character. If there is no wildcard, then simply call +;;; COPY-FILE-2; otherwise, resolve the wildcard and copy those matching files. +;;; +(defun copy-file-1 (pname1 wildp1 exists1p pname2 wildp2 update clobber) + (if wildp1 + (copy-wildcard-files pname1 wildp1 pname2 wildp2 update clobber) + (let ((ses-name1 (namestring pname1))) + (unless exists1p (funcall *error-function* + "~S does not exist." ses-name1)) + (copy-file-2 ses-name1 (namestring pname2) update clobber)))) + +(defun copy-wildcard-files (pname1 wildp1 pname2 wildp2 update clobber + &optional directory) + (multiple-value-bind (dst-before dst-after) + (before-wildcard-after (file-namestring pname2) wildp2) + (dolist (match (resolve-wildcard pname1 wildp1 directory)) + (copy-file-2 (wild-match-file match) + (namestring (concatenate 'simple-string + (directory-namestring pname2) + dst-before + (wild-match-substitute match) + dst-after)) + update clobber)))) + +;;; COPY-FILE-2 copies ses-name1 to ses-name2 depending on the values of update +;;; and clobber, with respect to the documentation of COPY-FILE. If ses-name2 +;;; doesn't exist, then just copy it; otherwise, if update, then only copy it +;;; if the destination's write date precedes the source's, and if not clobber +;;; and not update, then ask the user before doing the copy. +;;; +(defun copy-file-2 (ses-name1 ses-name2 update clobber) + (let ((secs1 (get-write-date ses-name1))) + (cond ((not (probe-file ses-name2)) + (do-the-copy ses-name1 ses-name2 secs1)) + (update + (let ((secs2 (get-write-date ses-name2))) + (cond (clobber + (do-the-copy ses-name1 ses-name2 secs1)) + ((and (> secs2 secs1) + (funcall *yesp-function* + "~&~S ==> ~S~% ~ + ** Destination is newer than source. ~ + Overwrite it? " + ses-name1 ses-name2)) + (do-the-copy ses-name1 ses-name2 secs1)) + ((< secs2 secs1) + (do-the-copy ses-name1 ses-name2 secs1))))) + ((not clobber) + (when (funcall *yesp-function* + "~&~S ==> ~S~% ** Destination already exists. ~ + Overwrite it? " + ses-name1 ses-name2) + (do-the-copy ses-name1 ses-name2 secs1))) + (t (do-the-copy ses-name1 ses-name2 secs1))))) + +(defun do-the-copy (ses-name1 ses-name2 secs1) + (let* ((fd (open-file ses-name1))) + (unwind-protect + (multiple-value-bind (data byte-count mode) + (read-file fd ses-name1) + (unwind-protect (write-file ses-name2 data byte-count mode) + (dispose-storage data byte-count))) + (close-file fd))) + (set-write-date ses-name2 secs1) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)) + + +;;;; Rename-File + +(defun rename-file (spec1 spec2 &key (clobber *clobber-default*) + (directory () directoryp)) + "Rename file spec1 to spec2. A single wildcard is acceptable, and spec2 may + be a directory with the result spec being the merging of spec2 with spec1. + If clobber is nil and spec2 exists, then the user will be asked to confirm + the renaming. As with Unix mv, if you are renaming a directory, don't + specify the trailing slash." + (cond + ((not directoryp) + (multiple-value-bind (ses-name1 exists1p) + (lisp::predict-name spec1 t) + (let* ((ses-name2 (lisp::predict-name spec2 nil)) + (pname1 (pathname ses-name1)) + (pname2 (pathname ses-name2)) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp (file-namestring pname1))) + (wildp2 (wildcardp (file-namestring pname2)))) + (if (and dirp2 wildp2) + (funcall *error-function* + "Cannot have wildcards in directory names -- ~S." pname2)) + (if (and wildp2 (not wildp1)) + (funcall *error-function* + "Cannot handle destination having wildcards without ~ + source having wildcards.")) + (if (and wildp1 (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (if dirp2 + (rename-file-1 pname1 wildp1 exists1p (merge-pathnames pname2 + pname1) + wildp1 clobber) + (rename-file-1 pname1 wildp1 exists1p pname2 wildp2 clobber))))) + (directory + (when (pathname-directory spec1) + (funcall *error-function* + "Spec1 is just a pattern when supplying directory -- ~S." + spec1)) + + (let* ((pname2 (pathname (lisp::predict-name spec2 nil))) + (dirp2 (directoryp pname2)) + (wildp1 (wildcardp spec1)) + (wildp2 (wildcardp (file-namestring pname2)))) + (unless wildp1 + (funcall *error-function* + "Pattern, ~S, does not contain a wildcard." + spec1)) + (when (and (not wildp2) (not dirp2)) + (funcall *error-function* + "Cannot handle source with wildcards and destination ~ + without, unless destination is a directory.")) + (rename-wildcard-files spec1 wildp1 + (if dirp2 (merge-pathnames pname2 spec1) pname2) + (if dirp2 wildp1 wildp2) + clobber directory)))) + (values)) + +;;; RENAME-FILE-1 takes pathnames which either both contain a single wildcard +;;; or none. Wildp1 and Wildp2 are either nil or indexes into the +;;; file-namestring of pname1 and pname2, respectively, indicating the position +;;; of the wildcard character. If there is no wildcard, then simply call +;;; RENAME-FILE-2; otherwise, resolve the wildcard and rename those matching files. +;;; +(defun rename-file-1 (pname1 wildp1 exists1p pname2 wildp2 clobber) + (if wildp1 + (rename-wildcard-files pname1 wildp1 pname2 wildp2 clobber) + (let ((ses-name1 (namestring pname1))) + (unless exists1p (funcall *error-function* + "~S does not exist." ses-name1)) + (rename-file-2 ses-name1 (namestring pname2) clobber)))) + +(defun rename-wildcard-files (pname1 wildp1 pname2 wildp2 clobber + &optional directory) + (multiple-value-bind (dst-before dst-after) + (before-wildcard-after (file-namestring pname2) wildp2) + (dolist (match (resolve-wildcard pname1 wildp1 directory)) + (rename-file-2 (wild-match-file match) + (namestring (concatenate 'simple-string + (directory-namestring pname2) + dst-before + (wild-match-substitute match) + dst-after)) + clobber)))) + +(defun rename-file-2 (ses-name1 ses-name2 clobber) + (cond ((and (probe-file ses-name2) (not clobber)) + (when (funcall *yesp-function* + "~&~S ==> ~S~% ** Destination already exists. ~ + Overwrite it? " + ses-name1 ses-name2) + (sub-rename-file ses-name1 ses-name2) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2))) + (t (sub-rename-file ses-name1 ses-name2) + (funcall *report-function* "~&~S ==>~% ~S~%" ses-name1 ses-name2)))) + + + +;;;; Find-File + +(defun find-file (file-name &optional (directory "") + (find-all-p nil find-all-suppliedp)) + "Find the file with file-namestring file recursively looking in directory. + If find-all-p is non-nil, then do not stop searching upon finding the first + occurance of file. File may contain a single wildcard, which causes + find-all-p to default to t instead of nil." + (let* ((file (coerce file-name 'simple-string)) + (wildp (wildcardp file)) + (find-all-p (if find-all-suppliedp find-all-p wildp))) + (declare (simple-string file)) + (catch 'found-file + (if wildp + (multiple-value-bind (before after) + (before-wildcard-after file wildp) + (find-file-aux file directory find-all-p before after)) + (find-file-aux file directory find-all-p)))) + (values)) + +(defun find-file-aux (the-file directory find-all-p &optional before after) + (declare (simple-string the-file)) + (dolist (spec (directory directory)) + (let* ((spec-ses-name (namestring spec)) + (spec-file-name (file-namestring spec-ses-name))) + (declare (simple-string spec-ses-name spec-file-name)) + (if (directoryp spec) + (find-file-aux the-file spec find-all-p before after) + (when (if before + (find-match before after spec-file-name :no-cons) + (string-equal the-file spec-file-name)) + (print spec-ses-name) + (unless find-all-p (throw 'found-file t))))))) + + + +;;;; Delete-File + +;;; DELETE-FILE +;;; If spec is a directory, but recursive is nil, just pass the directory +;;; down through, letting LISP:DELETE-FILE signal an error if the directory +;;; is not empty. +;;; +(defun delete-file (spec &key (recursive *recursive-default*) + (clobber *clobber-default*)) + "Delete spec asking confirmation on each file if clobber is nil. A single + wildcard is acceptable. If recursive is non-nil, then a directory spec may + be given to recursively delete the entirety of the directory and its + subdirectory structure. An empty directory may be specified without + recursive being non-nil. When specifying a directory, the trailing slash + must be included." + (let* ((ses-name (lisp::predict-name spec t)) + (pname (pathname ses-name)) + (wildp (wildcardp (file-namestring pname))) + (dirp (directoryp pname))) + (if dirp + (if recursive + (recursive-delete pname ses-name clobber) + (delete-file-2 ses-name clobber)) + (delete-file-1 pname ses-name wildp clobber))) + (values)) + +(defun recursive-delete (directory dir-ses-name clobber) + (dolist (spec (directory (directory-namestring directory))) + (let ((spec-ses-name (namestring spec))) + (if (directoryp spec) + (recursive-delete (pathname spec-ses-name) spec-ses-name clobber) + (delete-file-2 spec-ses-name clobber)))) + (delete-file-2 dir-ses-name clobber)) + +(defun delete-file-1 (pname ses-name wildp clobber) + (if wildp + (dolist (match (resolve-wildcard pname wildp)) + (delete-file-2 (wild-match-file match) clobber)) + (delete-file-2 ses-name clobber))) + +(defun delete-file-2 (ses-name clobber) + (when (or clobber (funcall *yesp-function* "~&Delete ~S? " ses-name)) + (if (directoryp ses-name) + (delete-directory ses-name) + (lisp:delete-file ses-name)) + (funcall *report-function* "~&~A~%" ses-name))) + + + +;;;; Wildcard resolution + +(defun pathnames-from-pattern (pattern files) + "Return a list of pathnames from files whose file-namestrings match + pattern. Pattern must be a non-empty string and contains only one + asterisk. Files contains no directories." + (declare (simple-string pattern)) + (when (string= pattern "") + (funcall *error-function* "Must be a non-empty pattern.")) + (unless (= (count wildcard-char pattern :test #'char=) 1) + (funcall *error-function* "Pattern must contain one asterisk.")) + (multiple-value-bind (before after) + (before-wildcard-after pattern (wildcardp pattern)) + (let ((result nil)) + (dolist (f files result) + (let* ((ses-namestring (namestring f)) + (f-namestring (file-namestring ses-namestring)) + (match (find-match before after f-namestring))) + (when match (push f result))))))) + + +;;; RESOLVE-WILDCARD takes a pathname with a wildcard and the position of the +;;; wildcard character in the file-namestring and returns a list of wild-match +;;; objects. When directory is supplied, pname is just a pattern, or a +;;; file-namestring. It is an error for directory to be anything other than +;;; absolute pathnames in the same directory. Each wild-match object contains +;;; the Sesame namestring of a file in the same directory as pname, or +;;; directory, and a simple-string representing what the wildcard matched. +;;; +(defun resolve-wildcard (pname wild-pos &optional directory) + (multiple-value-bind (before after) + (before-wildcard-after (if directory + pname + (file-namestring pname)) + wild-pos) + (let (result) + (dolist (f (or directory (directory (directory-namestring pname))) + (nreverse result)) + (unless (directoryp f) + (let* ((ses-namestring (namestring f)) + (f-namestring (file-namestring ses-namestring)) + (match (find-match before after f-namestring))) + (if match + (push (make-wild-match ses-namestring match) result)))))))) + +;;; FIND-MATCH takes a "before wildcard" and "after wildcard" string and a +;;; file-namestring. If before and after match a substring of file-namestring +;;; and are respectively left bound and right bound, then anything left in +;;; between is the match returned. If no match is found, nil is returned. +;;; NOTE: if version numbers ever really exist, then this code will have to be +;;; changed since the file-namestring of a pathname contains the version number. +;;; +(defun find-match (before after file-namestring &optional no-cons) + (declare (simple-string before after file-namestring)) + (let ((before-len (length before)) + (after-len (length after)) + (name-len (length file-namestring))) + (if (>= name-len (+ before-len after-len)) + (let* ((start (if (string= before file-namestring + :end1 before-len :end2 before-len) + before-len)) + (end (- name-len after-len)) + (matchp (and start + (string= after file-namestring :end1 after-len + :start2 end :end2 name-len)))) + (if matchp + (if no-cons + t + (subseq file-namestring start end))))))) + +(defun before-wildcard-after (file-namestring wild-pos) + (declare (simple-string file-namestring)) + (values (subseq file-namestring 0 wild-pos) + (subseq file-namestring (1+ wild-pos) (length file-namestring)))) + + + +;;;; Miscellaneous Utilities (e.g., MAKEDIR). + +(defun make-directory (name) + "Creates directory name. If name exists, then an error is signaled." + (multiple-value-bind (ses-name existsp) + (lisp::predict-name name nil) + (when existsp (funcall *error-function* + "Name already exists -- ~S" ses-name)) + (enter-directory ses-name)) + t) + + + +;;;; Mach Operations + +(defun open-file (ses-name) + (multiple-value-bind (fd err) + (mach:unix-open ses-name mach:o_rdonly 0) + (unless fd + (funcall *error-function* "Opening ~S failed: ~A." ses-name err)) + fd)) + +(defun close-file (fd) + (mach:unix-close fd)) + +(defun read-file (fd ses-name) + (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size) + (mach:unix-fstat fd) + (declare (ignore ino nlink uid gid rdev)) + (unless winp (funcall *error-function* + "Opening ~S failed: ~A." ses-name dev-or-err)) + (let ((storage (lisp::fixnum-to-sap (allocate-storage size)))) + (multiple-value-bind (read-bytes err) + (mach:unix-read fd storage size) + (when (or (null read-bytes) (not (= size read-bytes))) + (dispose-storage storage size) + (funcall *error-function* + "Reading file ~S failed: ~A." ses-name err))) + (values storage size mode)))) + +(defun dispose-storage (storage size) + (mach::vm_deallocate lisp::*task-self* + (lisp::sap-to-fixnum storage) + size)) + +(defun allocate-storage (size) + (lisp::do-validate 0 size -1)) + +(defun write-file (ses-name data byte-count mode) + (multiple-value-bind (fd err) (mach:unix-creat ses-name #o644) + (unless fd + (funcall *error-function* "Couldn't create file ~S: ~A" + ses-name (mach:get-unix-error-msg err))) + (multiple-value-bind (winp err) (mach:unix-write fd data 0 byte-count) + (unless winp + (funcall *error-function* "Writing file ~S failed: ~A" + ses-name + (mach:get-unix-error-msg err)))) + (mach:unix-fchmod fd (logand mode #o777)) + (mach:unix-close fd))) + +(defvar *utimes-buffer* (make-list 4 :initial-element 0)) + +(defun set-write-date (ses-name secs) + (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime) + (mach:unix-stat ses-name) + (declare (ignore ino mode nlink uid gid rdev size)) + (unless winp (funcall *error-function* + "Couldn't stat file ~S failed: ~A." ses-name + dev-or-err)) + (setf (car *utimes-buffer*) atime) + (setf (caddr *utimes-buffer*) secs)) + (multiple-value-bind (winp err) (mach:unix-utimes ses-name *utimes-buffer*) + (unless winp + (funcall *error-function* "Couldn't set write date of file ~S: ~A" + ses-name + (mach:get-unix-error-msg err))))) + +(defun get-write-date (ses-name) + (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size + atime mtime) + (mach:unix-stat ses-name) + (declare (ignore ino mode nlink uid gid rdev size atime)) + (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A." + ses-name dev-or-err)) + mtime)) + +;;; SUB-RENAME-FILE must exist because we can't use Common Lisp's RENAME-FILE. +;;; This is because it merges the new name with the old name to pick up +;;; defaults, and this conflicts with Unix-oid names. For example, renaming +;;; "foo.bar" to ".baz" causes a result of "foo.baz"! This routine doesn't +;;; have this problem. +;;; +(defun sub-rename-file (ses-name1 ses-name2) + (multiple-value-bind (res err) (mach:unix-rename ses-name1 ses-name2) + (unless res + (funcall *error-function* "Failed to rename ~A to ~A: ~A." + ses-name1 ses-name2 (mach:get-unix-error-msg err))))) + +(defun directory-existsp (ses-name) + (multiple-value-bind (winp type) + (mach:unix-subtestname ses-name) + (and winp (eq type :entry_directory)))) + +(defun enter-directory (ses-name) + (declare (simple-string ses-name)) + (let* ((length-1 (1- (length ses-name))) + (name (if (= (position #\/ ses-name :test #'char= :from-end t) + length-1) + (subseq ses-name 0 (1- (length ses-name))) + ses-name))) + (multiple-value-bind (winp err) (mach:unix-mkdir name #o755) + (unless winp + (funcall *error-function* "Couldn't make directory ~S: ~A" + name + (mach:get-unix-error-msg err)))))) + +(defun delete-directory (ses-name) + (declare (simple-string ses-name)) + (multiple-value-bind (winp err) + (mach:unix-rmdir (subseq ses-name 0 + (1- (length ses-name)))) + (unless winp + (funcall *error-function* "Couldn't delete directory ~S: ~A" + ses-name + (mach:get-unix-error-msg err))))) + + + +;;;; Misc. Utility Utilities + +;;; NSEPARATE-FILES destructively returns a list of file specs from listing. +(defun nseparate-files (listing) + (do (files hold) + ((null listing) files) + (setf hold (cdr listing)) + (unless (directoryp (car listing)) + (setf (cdr listing) files) + (setf files listing)) + (setf listing hold))) + + +(defun directoryp (p) + (not (or (pathname-name p) (pathname-type p)))) diff --git a/hemlock/diredcoms.lisp b/hemlock/diredcoms.lisp new file mode 100644 index 0000000000000000000000000000000000000000..7a95ef0339fd9525358444728b1482639328ebf1 --- /dev/null +++ b/hemlock/diredcoms.lisp @@ -0,0 +1,879 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Simple directory editing support. +;;; This file contains site dependent calls. +;;; +;;; Written by Blaine Burks and Bill Chiles. +;;; + +(in-package "HEMLOCK") + + +(defmode "Dired" :major-p t + :documentation + "Dired permits convenient directory browsing and file operations including + viewing, deleting, copying, renaming, and wildcard specifications.") + + +(defstruct (dired-information (:print-function print-dired-information) + (:conc-name dired-info-)) + pathname ; Pathname of directory. + pattern ; FILE-NAMESTRING with wildcard possibly. + dot-files-p ; Whether to include UNIX dot files. + write-date ; Write date of directory. + files ; Simple-vector of dired-file structures. + file-list) ; List of pathnames for files, excluding directories. + +(defun print-dired-information (obj str n) + (declare (ignore n)) + (format str "#<Dired Info ~S>" (namestring (dired-info-pathname obj)))) + + +(defstruct (dired-file (:print-function print-dired-file) + (:constructor make-dired-file (pathname))) + pathname + (deleted-p nil) + (write-date nil)) + +(defun print-dired-file (obj str n) + (declare (ignore n)) + (format str "#<Dired-file ~A>" (namestring (dired-file-pathname obj)))) + + + +;;;; "Dired" command. + +;;; *pathnames-to-dired-buffers* is an a-list mapping directory namestrings to +;;; buffers that display their contents. +;;; +(defvar *pathnames-to-dired-buffers* ()) + +(make-modeline-field + :name :dired-cmds :width 20 + :function + #'(lambda (buffer window) + (declare (ignore buffer window)) + " Type ? for help. ")) + +(defcommand "Dired" (p &optional directory) + "Prompt for a directory and edit it. If a dired for that directory already + exists, go to that buffer, otherwise create one. With an argument, include + UNIX dot files." + "Prompt for a directory and edit it. If a dired for that directory already + exists, go to that buffer, otherwise create one. With an argument, include + UNIX dot files." + (let ((info (if directory (value dired-information)))) + (dired-guts nil + ;; Propagate dot-files property to subdirectory edits. + (or (and info (dired-info-dot-files-p info)) + p) + directory))) + +(defcommand "Dired with Pattern" (p) + "Do a dired, prompting for a pattern which may include a single *. With an + argument, include UNIX dit files." + "Do a dired, prompting for a pattern which may include a single *. With an + argument, include UNIX dit files." + (dired-guts t p nil)) + +(defun dired-guts (patternp dot-files-p directory) + (let* ((dpn (value pathname-defaults)) + (directory (dired-directorify + (or directory + (prompt-for-file + :prompt "Edit Directory: " + :help "Pathname to edit." + :default (make-pathname + :device (pathname-device dpn) + :directory (pathname-directory dpn)) + :must-exist nil)))) + (pattern (if patternp + (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t))) + (full-name (namestring (if pattern + (merge-pathnames directory pattern) + directory))) + (name (concatenate 'simple-string "Dired " full-name)) + (buffer (cdr (assoc full-name *pathnames-to-dired-buffers* + :test #'string=)))) + (declare (simple-string full-name)) + (setf (value pathname-defaults) (merge-pathnames directory dpn)) + (change-to-buffer + (cond (buffer + (when (and dot-files-p + (not (dired-info-dot-files-p + (variable-value 'dired-information + :buffer buffer)))) + (setf (dired-info-dot-files-p (variable-value 'dired-information + :buffer buffer)) + t) + (update-dired-buffer directory pattern buffer)) + buffer) + (t + (let ((buffer (make-buffer + name :modes '("Dired") + :modeline-fields + (append (value default-modeline-fields) + (list (modeline-field :dired-cmds))) + :delete-hook (list 'dired-buffer-delete-hook)))) + (unless (initialize-dired-buffer directory pattern + dot-files-p buffer) + (delete-buffer-if-possible buffer) + (editor-error "No entries for ~A." full-name)) + (push (cons full-name buffer) *pathnames-to-dired-buffers*) + buffer)))))) + +;;; INITIALIZE-DIRED-BUFFER gets a dired in the buffer and defines some +;;; variables to make it usable as a dired buffer. If there are no file +;;; satisfying directory, then this returns nil, otherwise t. +;;; +(defun initialize-dired-buffer (directory pattern dot-files-p buffer) + (multiple-value-bind (pathnames dired-files) + (dired-in-buffer directory pattern dot-files-p buffer) + (if (zerop (length dired-files)) + nil + (defhvar "Dired Information" + "Contains the information neccessary to manipulate dired buffers." + :buffer buffer + :value (make-dired-information :pathname directory + :pattern pattern + :dot-files-p dot-files-p + :write-date (file-write-date directory) + :files dired-files + :file-list pathnames))))) + +;;; CALL-PRINT-DIRECTORY gives us a nice way to report PRINT-DIRECTORY errors +;;; to the user and to clean up the dired buffer. +;;; +(defun call-print-directory (directory mark dot-files-p) + (handler-case (with-output-to-mark (s mark :full) + (print-directory directory s + :all dot-files-p :verbose t :return-list t)) + (error (condx) + (delete-buffer-if-possible (line-buffer (mark-line mark))) + (editor-error "~A" condx)))) + +;;; DIRED-BUFFER-DELETE-HOOK is called on dired buffers upon deletion. This +;;; removes the buffer from the pathnames mapping, and it deletes and buffer +;;; local variables referring to it. +;;; +(defun dired-buffer-delete-hook (buffer) + (setf *pathnames-to-dired-buffers* + (delete buffer *pathnames-to-dired-buffers* :test #'eq :key #'cdr))) + + + +;;;; Dired deletion and undeletion. + +(defcommand "Dired Delete File" (p) + "Marks a file for deletion; signals an error if not in a dired buffer. + With an argument, this prompts for a pattern that may contain at most one + wildcard, an asterisk, and all names matching the pattern will be flagged + for deletion." + "Marks a file for deletion; signals an error if not in a dired buffer." + (dired-frob-deletion p t)) + +(defcommand "Dired Undelete File" (p) + "Removes a mark for deletion; signals and error if not in a dired buffer. + With an argument, this prompts for a pattern that may contain at most one + wildcard, an asterisk, and all names matching the pattern will be unflagged + for deletion." + "Removes a mark for deletion; signals and error if not in a dired buffer." + (dired-frob-deletion p nil)) + +(defcommand "Dired Delete File and Down Line" (p) + "Marks file for deletion and moves down a line. + See \"Dired Delete File\"." + "Marks file for deletion and moves down a line. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion nil t) + (dired-down-line (current-point))) + +(defcommand "Dired Undelete File and Down Line" (p) + "Marks file undeleted and moves down a line. + See \"Dired Delete File\"." + "Marks file undeleted and moves down a line. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion nil nil) + (dired-down-line (current-point))) + +(defcommand "Dired Delete File with Pattern" (p) + "Prompts for a pattern and marks matching files for deletion. + See \"Dired Delete File\"." + "Prompts for a pattern and marks matching files for deletion. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion t t) + (dired-down-line (current-point))) + +(defcommand "Dired Undelete File with Pattern" (p) + "Prompts for a pattern and marks matching files undeleted. + See \"Dired Delete File\"." + "Prompts for a pattern and marks matching files undeleted. + See \"Dired Delete File\"." + (declare (ignore p)) + (dired-frob-deletion t nil) + (dired-down-line (current-point))) + +;;; DIRED-FROB-DELETION takes arguments indicating whether to prompt for a +;;; pattern and whether to mark the file deleted or undeleted. This uses +;;; CURRENT-POINT and CURRENT-BUFFER, and if not in a dired buffer, signal +;;; an error. +;;; +(defun dired-frob-deletion (patternp deletep) + (unless (hemlock-bound-p 'dired-information) + (editor-error "Not in Dired buffer.")) + (with-mark ((mark (current-point) :left-inserting)) + (let* ((dir-info (value dired-information)) + (files (dired-info-files dir-info)) + (del-files + (if patternp + (dired:pathnames-from-pattern + (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t) + (dired-info-file-list dir-info)) + (list (dired-file-pathname + (array-element-from-mark mark files))))) + (note-char (if deletep #\D #\space))) + (with-writable-buffer ((current-buffer)) + (dolist (f del-files) + (let* ((pos (position f files :test #'equal + :key #'dired-file-pathname)) + (dired-file (svref files pos))) + (buffer-start mark) + (line-offset mark pos 0) + (setf (dired-file-deleted-p dired-file) deletep) + (if deletep + (setf (dired-file-write-date dired-file) + (file-write-date (dired-file-pathname dired-file))) + (setf (dired-file-write-date dired-file) nil)) + (setf (next-character mark) note-char))))))) + +(defun dired-down-line (point) + (line-offset point 1) + (when (blank-line-p (mark-line point)) + (line-offset point -1))) + + + +;;;; Dired file finding and going to dired buffers. + +(defcommand "Dired Edit File" (p) + "Read in file or recursively \"Dired\" a directory." + "Read in file or recursively \"Dired\" a directory." + (declare (ignore p)) + (let ((point (current-point))) + (when (blank-line-p (mark-line point)) (editor-error "Not on a file line.")) + (let ((pathname (dired-file-pathname + (array-element-from-mark + point (dired-info-files (value dired-information)))))) + (if (directoryp pathname) + (dired-command nil (directory-namestring pathname)) + (change-to-buffer (find-file-buffer pathname)))))) + +(defcommand "Dired View File" (p) + "Read in file as if by \"View File\" or recursively \"Dired\" a directory. + This associates the file's buffer with the dired buffer." + "Read in file as if by \"View File\". + This associates the file's buffer with the dired buffer." + (declare (ignore p)) + (let ((point (current-point))) + (when (blank-line-p (mark-line point)) (editor-error "Not on a file line.")) + (let ((pathname (dired-file-pathname + (array-element-from-mark + point (dired-info-files (value dired-information)))))) + (if (directoryp pathname) + (dired-command nil (directory-namestring pathname)) + (let* ((dired-buf (current-buffer)) + (buffer (view-file-command nil pathname))) + (push #'(lambda (buffer) + (declare (ignore buffer)) + (setf dired-buf nil)) + (buffer-delete-hook dired-buf)) + (setf (variable-value 'view-return-function :buffer buffer) + #'(lambda () + (if dired-buf + (change-to-buffer dired-buf) + (dired-from-buffer-pathname-command nil))))))))) + +(defcommand "Dired from Buffer Pathname" (p) + "Invokes \"Dired\" on the directory part of the current buffer's pathname. + With an argument, also prompt for a file pattern within that directory." + "Invokes \"Dired\" on the directory part of the current buffer's pathname. + With an argument, also prompt for a file pattern within that directory." + (let ((pathname (buffer-pathname (current-buffer)))) + (if pathname + (dired-command p (directory-namestring pathname)) + (editor-error "No pathname associated with buffer.")))) + + + +;;;; Dired misc. commands -- update, help, line motion. + +(defcommand "Dired Update Buffer" (p) + "Recompute the contents of a dired buffer. + This maintains delete flags for files that have not been modified." + "Recompute the contents of a dired buffer. + This maintains delete flags for files that have not been modified." + (declare (ignore p)) + (unless (hemlock-bound-p 'dired-information) + (editor-error "Not in Dired buffer.")) + (let ((buffer (current-buffer)) + (dir-info (value dired-information))) + (update-dired-buffer (dired-info-pathname dir-info) + (dired-info-pattern dir-info) + buffer))) + +;;; UPDATE-DIRED-BUFFER updates buffer with a dired of directory, deleting +;;; whatever is in the buffer already. This assumes buffer was previously +;;; used as a dired buffer having necessary variables bound. The new files +;;; are compared to the old ones propagating any deleted flags if the name +;;; and the write date is the same for both specifications. +;;; +(defun update-dired-buffer (directory pattern buffer) + (with-writable-buffer (buffer) + (delete-region (buffer-region buffer)) + (let ((dir-info (variable-value 'dired-information :buffer buffer))) + (multiple-value-bind (pathnames new-dired-files) + (dired-in-buffer directory pattern + (dired-info-dot-files-p dir-info) + buffer) + (let ((point (buffer-point buffer)) + (old-dired-files (dired-info-files dir-info))) + (declare (simple-vector old-dired-files)) + (dotimes (i (length old-dired-files)) + (let ((old-file (svref old-dired-files i))) + (when (dired-file-deleted-p old-file) + (let ((pos (position (dired-file-pathname old-file) + new-dired-files :test #'equal + :key #'dired-file-pathname))) + (when pos + (let* ((new-file (svref new-dired-files pos)) + (write-date (file-write-date + (dired-file-pathname new-file)))) + (when (= (dired-file-write-date old-file) write-date) + (setf (dired-file-deleted-p new-file) t) + (setf (dired-file-write-date new-file) write-date) + (setf (next-character + (line-offset (buffer-start point) pos 0)) + #\D)))))))) + (setf (dired-info-files dir-info) new-dired-files) + (setf (dired-info-file-list dir-info) pathnames) + (setf (dired-info-write-date dir-info) + (file-write-date directory)) + (move-mark point (buffer-start-mark buffer))))))) + +;;; DIRED-IN-BUFFER inserts a dired listing of directory in buffer returning +;;; two values: a list of pathnames of files only, and an array of dired-file +;;; structures. This uses FILTER-REGION to insert a space for the indication +;;; of whether the file is flagged for deletion. Then we clean up extra header +;;; and trailing lines known to be in the output (into every code a little +;;; slime must fall). +;;; +(defun dired-in-buffer (directory pattern dot-files-p buffer) + (let ((point (buffer-point buffer))) + (with-writable-buffer (buffer) + (let* ((pathnames (call-print-directory + (if pattern + (merge-pathnames directory pattern) + directory) + point + dot-files-p)) + (dired-files (make-array (length pathnames)))) + (declare (list pathnames) (simple-vector dired-files)) + (filter-region #'(lambda (str) + (concatenate 'simple-string " " str)) + (buffer-region buffer)) + (delete-characters point -2) + (delete-region (line-to-region (mark-line (buffer-start point)))) + (delete-characters point) + (do ((p pathnames (cdr p)) + (i 0 (1+ i))) + ((null p)) + (setf (svref dired-files i) (make-dired-file (car p)))) + (values (delete-if #'directoryp pathnames) dired-files))))) + + +(defcommand "Dired Help" (p) + "How to use dired." + "How to use dired." + (declare (ignore p)) + (describe-mode-command nil "Dired")) + +(defcommand "Dired Next File" (p) + "Moves to next undeleted file." + "Moves to next undeleted file." + (declare (ignore p)) + (unless (dired-line-offset (current-point) (or p 1)) + (editor-error "Not enough lines."))) + +(defcommand "Dired Previous File" (p) + "Moves to previous undeleted file." + "Moves to next undeleted file." + (declare (ignore p)) + (unless (dired-line-offset (current-point) (or p -1)) + (editor-error "Not enough lines."))) + +;;; DIRED-LINE-OFFSET moves mark n undeleted file lines, returning mark. If +;;; there are not enough lines, mark remains unmoved, this returns nil. +;;; +(defun dired-line-offset (mark n) + (with-mark ((m mark)) + (let ((step (if (plusp n) 1 -1))) + (dotimes (i (abs n) (move-mark mark m)) + (loop + (unless (line-offset m step 0) + (return-from dired-line-offset nil)) + (when (blank-line-p (mark-line m)) + (return-from dired-line-offset nil)) + (when (char= (next-character m) #\space) + (return))))))) + + + +;;;; Dired user interaction functions. + +(defun dired-error-function (string &rest args) + (apply #'editor-error string args)) + +(defun dired-report-function (string &rest args) + (clear-echo-area) + (apply #'message string args)) + +(defun dired-yesp-function (string &rest args) + (prompt-for-y-or-n :prompt (cons string args) :default t)) + + + +;;;; Dired expunging and quitting. + +(defcommand "Dired Expunge Files" (p) + "Expunges files marked for deletion. + Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do + the same with directories and the value of \"Dired Directory Expunge + Confirm\"." + "Expunges files marked for deletion. + Query the user if value of \"Dired File Expunge Confirm\" is non-nil. Do + the same with directories and the value of \"Dired Directory Expunge + Confirm\"." + (declare (ignore p)) + (when (expunge-dired-files) + (dired-update-buffer-command nil)) + (maintain-dired-consistency)) + +(defcommand "Dired Quit" (p) + "Expunges the files in a dired buffer and then exits." + "Expunges the files in a dired buffer and then exits." + (declare (ignore p)) + (expunge-dired-files) + (delete-buffer-if-possible (current-buffer))) + +(defhvar "Dired File Expunge Confirm" + "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask + for confirmation before deleting the marked files." + :value t) + +(defhvar "Dired Directory Expunge Confirm" + "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask + for confirmation before deleting each marked directory." + :value t) + +(defun expunge-dired-files () + (multiple-value-bind (marked-files marked-dirs) (get-marked-dired-files) + (let ((dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function) + (we-did-something nil)) + (when (and marked-files + (or (not (value dired-file-expunge-confirm)) + (prompt-for-y-or-n :prompt "Really delete files? " + :default t + :must-exist t + :default-string "Y"))) + (setf we-did-something t) + (dolist (file-info marked-files) + (let ((pathname (car file-info)) + (write-date (cdr file-info))) + (if (= write-date (file-write-date pathname)) + (dired:delete-file (namestring pathname) :clobber t + :recursive nil) + (message "~A has been modified, it remains unchanged." + (namestring pathname)))))) + (when marked-dirs + (dolist (dir-info marked-dirs) + (let ((dir (car dir-info)) + (write-date (cdr dir-info))) + (if (= write-date (file-write-date dir)) + (when (or (not (value dired-directory-expunge-confirm)) + (prompt-for-y-or-n + :prompt (list "~a is a directory. Delete it? " + (directory-namestring dir)) + :default t + :must-exist t + :default-string "Y")) + (dired:delete-file (directory-namestring dir) :clobber t + :recursive t) + (setf we-did-something t)) + (message "~A has been modified, it remains unchanged."))))) + we-did-something))) + + + +;;;; Dired copying and renaming. + +(defhvar "Dired Copy File Confirm" + "Can be either t, nil, or :update. T means always query before clobbering an + existing file, nil means don't query before clobbering an existing file, and + :update means only ask if the existing file is newer than the source." + :value T) + +(defhvar "Dired Rename File Confirm" + "When non-nil, dired will query before clobbering an existing file." + :value T) + +(defcommand "Dired Copy File" (p) + "Copy the file under the point" + "Copy the file under the point" + (declare (ignore p)) + (let* ((point (current-point)) + (confirm (value dired-copy-file-confirm)) + (source (dired-file-pathname + (array-element-from-mark + point (dired-info-files (value dired-information))))) + (dest (prompt-for-file + :prompt (if (directoryp source) + "Destination Directory Name: " + "Destination Filename: ") + :help "Name of new file." + :default source + :must-exist nil)) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (dired:copy-file source dest :update (if (eq confirm :update) t nil) + :clobber (not confirm))) + (maintain-dired-consistency)) + +(defcommand "Dired Rename File" (p) + "Rename the file or directory under the point" + "Rename the file or directory under the point" + (declare (ignore p)) + (let* ((point (current-point)) + (source (dired-namify (dired-file-pathname + (array-element-from-mark + point + (dired-info-files (value dired-information)))))) + (dest (prompt-for-file + :prompt "New Filename: " + :help "The new name for this file." + :default source + :must-exist nil)) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + ;; ARRAY-ELEMENT-FROM-MARK moves mark to line start. + (dired:rename-file source dest :clobber (value dired-rename-file-confirm))) + (maintain-dired-consistency)) + +(defcommand "Dired Copy with Wildcard" (p) + "Copy files that match a pattern containing ONE wildcard." + "Copy files that match a pattern containing ONE wildcard." + (declare (ignore p)) + (let* ((dir-info (value dired-information)) + (confirm (value dired-copy-file-confirm)) + (pattern (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t)) + (destination (namestring + (prompt-for-file + :prompt "Destination Spec: " + :help "Destination spec. May contain ONE asterisk." + :default (dired-info-pathname dir-info) + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*yesp-function* #'dired-yesp-function) + (dired:*report-function* #'dired-report-function)) + (dired:copy-file pattern destination :update (if (eq confirm :update) t nil) + :clobber (not confirm) + :directory (dired-info-file-list dir-info))) + (maintain-dired-consistency)) + +(defcommand "Dired Rename with Wildcard" (p) + "Rename files that match a pattern containing ONE wildcard." + "Rename files that match a pattern containing ONE wildcard." + (declare (ignore p)) + (let* ((dir-info (value dired-information)) + (pattern (prompt-for-string + :prompt "Filename pattern: " + :help "Type a filename with a single asterisk." + :trim t)) + (destination (namestring + (prompt-for-file + :prompt "Destination Spec: " + :help "Destination spec. May contain ONE asterisk." + :default (dired-info-pathname dir-info) + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*yesp-function* #'dired-yesp-function) + (dired:*report-function* #'dired-report-function)) + (dired:rename-file pattern destination + :clobber (not (value dired-rename-file-confirm)) + :directory (dired-info-file-list dir-info))) + (maintain-dired-consistency)) + +(defcommand "Delete File" (p) + "Delete a file. Specify directories with a trailing slash." + "Delete a file. Specify directories with a trailing slash." + (declare (ignore p)) + (let* ((spec (namestring + (prompt-for-file + :prompt "Delete File: " + :help '("Name of File or Directory to delete. ~ + One wildcard is permitted.") + :must-exist nil))) + (directoryp (directoryp spec)) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (when (or (not directoryp) + (not (value dired-directory-expunge-confirm)) + (prompt-for-y-or-n + :prompt (list "~A is a directory. Delete it? " + (directory-namestring spec)) + :default t :must-exist t :default-string "Y"))) + (dired:delete-file spec :recursive t + :clobber (or directoryp + (value dired-file-expunge-confirm)))) + (maintain-dired-consistency)) + +(defcommand "Copy File" (p) + "Copy a file, allowing ONE wildcard." + "Copy a file, allowing ONE wildcard." + (declare (ignore p)) + (let* ((confirm (value dired-copy-file-confirm)) + (source (namestring + (prompt-for-file + :prompt "Source Filename: " + :help "Name of File to copy. One wildcard is permitted." + :must-exist nil))) + (dest (namestring + (prompt-for-file + :prompt (if (directoryp source) + "Destination Directory Name: " + "Destination Filename: ") + :help "Name of new file." + :default source + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (dired:copy-file source dest :update (if (eq confirm :update) t nil) + :clobber (not confirm))) + (maintain-dired-consistency)) + +(defcommand "Rename File" (p) + "Rename a file, allowing ONE wildcard." + "Rename a file, allowing ONE wildcard." + (declare (ignore p)) + (let* ((source (namestring + (prompt-for-file + :prompt "Source Filename: " + :help "Name of file to rename. One wildcard is permitted." + :must-exist nil))) + (dest (namestring + (prompt-for-file + :prompt (if (directoryp source) + "Destination Directory Name: " + "Destination Filename: ") + :help "Name of new file." + :default source + :must-exist nil))) + (dired:*error-function* #'dired-error-function) + (dired:*report-function* #'dired-report-function) + (dired:*yesp-function* #'dired-yesp-function)) + (dired:rename-file source dest + :clobber (not (value dired-rename-file-confirm)))) + (maintain-dired-consistency)) + +(defun maintain-dired-consistency () + (dolist (info *pathnames-to-dired-buffers*) + (let* ((directory (directory-namestring (car info))) + (buffer (cdr info)) + (dir-info (variable-value 'dired-information :buffer buffer)) + (write-date (file-write-date directory))) + (unless (= (dired-info-write-date dir-info) write-date) + (update-dired-buffer directory (dired-info-pattern dir-info) buffer))))) + + + +;;;; Dired utilities. + +;;; GET-MARKED-DIRED-FILES returns as multiple values a list of file specs +;;; and a list of directory specs that have been marked for deletion. This +;;; assumes the current buffer is a "Dired" buffer. +;;; +(defun get-marked-dired-files () + (let* ((files (dired-info-files (value dired-information))) + (length (length files)) + (marked-files ()) + (marked-dirs ())) + (unless files (editor-error "Not in Dired buffer.")) + (do ((i 0 (1+ i))) + ((= i length) (values (nreverse marked-files) (nreverse marked-dirs))) + (let* ((thing (svref files i)) + (pathname (dired-file-pathname thing))) + (when (dired-file-deleted-p thing) + (if (directoryp pathname) + (push (cons pathname (file-write-date pathname)) marked-dirs) + (push (cons pathname (file-write-date pathname)) + marked-files))))))) + +;;; ARRAY-ELEMENT-FROM-MARK counts the lines between it and the beginning +;;; of the buffer. The number is used to index vector as if each line +;;; mapped to an element starting with the zero'th element (lines are +;;; numbered starting at 1). +;;; +(defun array-element-from-mark (mark vector + &optional (error-msg "Invalid line.")) + (when (blank-line-p (mark-line mark)) (editor-error error-msg)) + (svref vector + (1- (count-lines (region + (buffer-start-mark (line-buffer (mark-line mark))) + mark))))) + +;;; DIRED-NAMIFY and DIRED-DIRECTORIFY are implementation dependent slime. +;;; +(defun dired-namify (pathname) + (let* ((string (namestring pathname)) + (last (1- (length string)))) + (if (char= (schar string last) #\/) + (subseq string 0 last) + string))) +;;; +;;; This is necessary to derive a canonical representation for directory +;;; names, so "Dired" can map various strings naming one directory to that +;;; one directory. +;;; +(defun dired-directorify (pathname) + (let ((directory (lisp::predict-name pathname t))) + (if (directoryp directory) + directory + (pathname (concatenate 'simple-string (namestring directory) "/"))))) + + + +;;;; View Mode. + +(defmode "View" :major-p nil + :setup-function 'setup-view-mode + :cleanup-function 'cleanup-view-mode + :precedence 5.0 + :documentation + "View mode scrolls forwards and backwards in a file with the buffer read-only. + Scrolling off the end optionally deletes the buffer.") + +(defun setup-view-mode (buffer) + (defhvar "View Return Function" + "Function that gets called when quitting or returning from view mode." + :value nil + :buffer buffer) + (setf (buffer-writable buffer) nil)) +;;; +(defun cleanup-view-mode (buffer) + (delete-variable 'view-return-function :buffer buffer) + (setf (buffer-writable buffer) t)) + +(defcommand "View File" (p &optional pathname) + "Reads a file in as if by \"Find File\", but read-only. Commands exist + for scrolling convenience." + "Reads a file in as if by \"Find File\", but read-only. Commands exist + for scrolling convenience." + (declare (ignore p)) + (let* ((pn (or pathname + (prompt-for-file + :prompt "View File: " :must-exist t + :help "Name of existing file to read into its own buffer." + :default (buffer-default-pathname (current-buffer))))) + (buffer (make-buffer (format nil "View File ~A" (gensym))))) + (visit-file-command nil pn buffer) + (setf (buffer-minor-mode buffer "View") t) + (change-to-buffer buffer) + buffer)) + +(defcommand "View Return" (p) + "Return to a parent buffer, if it exists." + "Return to a parent buffer, if it exists." + (declare (ignore p)) + (unless (call-view-return-fun) + (editor-error "No View return method for this buffer."))) + +(defcommand "View Quit" (p) + "Delete a buffer in view mode." + "Delete a buffer in view mode, invoking VIEW-RETURN-FUNCTION if it exists for + this buffer." + (declare (ignore p)) + (let* ((buf (current-buffer)) + (funp (call-view-return-fun))) + (delete-buffer-if-possible buf) + (unless funp (editor-error "No View return method for this buffer.")))) + +;;; CALL-VIEW-RETURN-FUN returns nil if there is no current +;;; view-return-function. If there is one, it calls it and returns t. +;;; +(defun call-view-return-fun () + (if (hemlock-bound-p 'view-return-function) + (let ((fun (value view-return-function))) + (cond (fun + (funcall fun) + t))))) + + +(defhvar "View Scroll Deleting Buffer" + "When this is set, \"View Scroll Down\" deletes the buffer when the end + of the file is visible." + :value t) + +(defcommand "View Scroll Down" (p) + "Scroll the current window down through its buffer. + If the end of the file is visible, then delete the buffer if \"View Scroll + Deleting Buffer\" is set. If the buffer is associated with a dired buffer, + this returns there instead of to the previous buffer." + "Scroll the current window down through its buffer. + If the end of the file is visible, then delete the buffer if \"View Scroll + Deleting Buffer\" is set. If the buffer is associated with a dired buffer, + this returns there instead of to the previous buffer." + (if (and (not p) + (displayed-p (buffer-end-mark (current-buffer)) + (current-window)) + (value view-scroll-deleting-buffer)) + (view-quit-command nil) + (scroll-window-down-command p))) + +(defcommand "View Edit File" (p) + "Turn off \"View\" mode in this buffer." + "Turn off \"View\" mode in this buffer." + (declare (ignore p)) + (let ((buf (current-buffer))) + (setf (buffer-minor-mode buf "View") nil) + (warn-about-visit-file-buffers buf))) + +(defcommand "View Help" (p) + "Shows \"View\" mode help message." + "Shows \"View\" mode help message." + (declare (ignore p)) + (describe-mode-command nil "View")) diff --git a/hemlock/echocoms.lisp b/hemlock/echocoms.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a171aa7d3caa46f2b02d3edcea15298219d00d16 --- /dev/null +++ b/hemlock/echocoms.lisp @@ -0,0 +1,315 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Echo area commands. +;;; +;;; Written by Rob MacLachlan and Skef Wholey. +;;; +(in-package 'hemlock) + +(defhvar "Beep on Ambiguity" + "If non-NIL, beep when completion of a parse is ambiguous." + :value t) + +(defhvar "Ignore File Types" + "File types to ignore when trying to complete a filename." + :value + (list "fasl" "err" ; Lisp + "BAK" "CKP" ; Backups & Checkpoints + "PS" "ps" "press" "otl" "dvi" "toc" ; Formatting + "bbl" "lof" "idx" "lot" "aux" ; Formatting + "mo" "elc" ; Other editors + "bin" "lbin" ; Obvious binary extensions. + "o" "a" "aout" ; UNIXY stuff + "bm" "onx" "snf" ; X stuff + "UU" "uu" "arc" "Z" "tar" ; Binary encoded files + )) + + +;;; Field separator characters separate fields for TOPS-20 ^F style +;;; completion. +(defattribute "Parse Field Separator" + "A value of 1 for this attribute indicates that the corresponding character + should be considered to be a field separator by the prompting commands.") +(setf (character-attribute :parse-field-separator #\space) 1) + + +;;; Find-All-Completions -- Internal +;;; +;;; Return as a list of all the possible completions of String in the +;;; list of string-tables Tables. +;;; +(defun find-all-completions (string tables) + (do ((table tables (cdr table)) + (res () + (merge 'list (find-ambiguous string (car table)) + res #'string-lessp))) + ((null table) res))) + +(defcommand "Help on Parse" (p) + "Display help for parse in progress. + If there are a limited number of options then display them." + "Display the *Parse-Help* and any possibly completions of the current + input." + (declare (ignore p)) + (let ((help (typecase *parse-help* + (list (unless *parse-help* (error "There is no parse help.")) + (apply #'format nil *parse-help*)) + (string *parse-help*) + (t (error "Parse help is not a string or list: ~S" *parse-help*)))) + (input (region-to-string *parse-input-region*))) + (cond + ((eq *parse-type* :keyword) + (let ((strings (find-all-completions input *parse-string-tables*))) + (with-pop-up-display (s :height (+ (length strings) 2)) + (write-line help s) + (cond (strings + (write-line "Possible completions of what you have typed:" s) + (dolist (string strings) + (write-line string s))) + (t + (write-line + "There are no possible completions of what you have typed." s)))))) + ((and (eq *parse-type* :file) (not (zerop (length input)))) + (let ((pns (ambiguous-files (region-to-string *parse-input-region*) + *parse-default*))) + (declare (list pns)) + (with-pop-up-display(s :height (+ (length pns) 2)) + (write-line help s) + (cond (pns + (write-line "Possible completions of what you have typed:" s) + (dolist (pn pns) + (format s " ~A~25T ~A~%" (file-namestring pn) + (directory-namestring pn)))) + (t + (write-line + "There are no possible completions of what you have typed." s)))))) + (t + (with-mark ((m (buffer-start-mark *echo-area-buffer*) :left-inserting)) + (insert-string m help) + (insert-character m #\newline)))))) + +(defun file-completion-action (typein) + (declare (simple-string typein)) + (when (zerop (length typein)) (editor-error)) + (multiple-value-bind + (result win) + (complete-file typein + :defaults (directory-namestring *parse-default*) + :ignore-types (value ignore-file-types)) + (when result + (delete-region *parse-input-region*) + (insert-string (region-start *parse-input-region*) + (namestring result))) + (when (and (not win) (value beep-on-ambiguity)) + (editor-error)))) + +(defcommand "Complete Keyword" (p) + "Trys to complete the text being read in the echo area as a string in + *parse-string-tables*" + "Complete the keyword being parsed as far as possible. + If it is ambiguous and ``Beep On Ambiguity'' true beep." + (declare (ignore p)) + (let ((typein (region-to-string *parse-input-region*))) + (declare (simple-string typein)) + (case *parse-type* + (:keyword + (multiple-value-bind + (prefix key value field ambig) + (complete-string typein *parse-string-tables*) + (declare (ignore value field)) + (when prefix + (delete-region *parse-input-region*) + (insert-string (region-start *parse-input-region*) prefix) + (when (eq key :ambiguous) + (let ((point (current-point))) + (move-mark point (region-start *parse-input-region*)) + (unless (character-offset point ambig) + (buffer-end point))))) + (when (and (or (eq key :ambiguous) (eq key :none)) + (value beep-on-ambiguity)) + (editor-error)))) + (:file + (file-completion-action typein)) + (t + (editor-error "Cannot complete input for this prompt."))))) + +(defun field-separator-p (x) + (plusp (character-attribute :parse-field-separator x))) + +(defcommand "Complete Field" (p) + "Complete a field in a parse. + Fields are defined by the :field separator attribute, + the text being read in the echo area as a string in *parse-string-tables*" + "Complete a field in a keyword. + If it is ambiguous and ``Beep On Ambiguity'' true beep. Fields are + separated by characters having a non-zero :parse-field-separator attribute, + and this command should only be bound to characters having that attribute." + (let ((typein (region-to-string *parse-input-region*))) + (declare (simple-string typein)) + (case *parse-type* + (:string + (self-insert-command p)) + (:file + (file-completion-action typein)) + (:keyword + (let ((point (current-point))) + (unless (blank-after-p point) + (insert-character point *last-character-typed*))) + (multiple-value-bind + (prefix key value field ambig) + (complete-string typein *parse-string-tables*) + (declare (ignore value ambig)) + (when (eq key :none) (editor-error "No possible completion.")) + (delete-region *parse-input-region*) + (let ((new-typein (if (and (eq key :unique) (null field)) + (subseq prefix 0 field) + (concatenate 'string + (subseq prefix 0 field) + (string *last-character-typed*))))) + (insert-string (region-start *parse-input-region*) new-typein)))) + (t + (editor-error "Cannot complete input for this prompt."))))) + + +(defvar *echo-area-history* (make-ring 10) + "This ring-buffer contains strings which were previously input in the + echo area.") + +(defvar *echo-history-pointer* 0 + "This is our current position to the ring during a historical exploration.") + +(defcommand "Confirm Parse" (p) + "Terminate echo-area input. + If the input is invalid then an editor-error will signalled." + "If no input has been given, exits the recursive edit with the default, + otherwise calls the verification function." + (declare (ignore p)) + (let* ((string (region-to-string *parse-input-region*)) + (empty (zerop (length string)))) + (declare (simple-string string)) + (if empty + (when *parse-default* (setq string *parse-default*)) + (when (or (zerop (ring-length *echo-area-history*)) + (string/= string (ring-ref *echo-area-history* 0))) + (ring-push string *echo-area-history*))) + (multiple-value-bind (res flag) + (funcall *parse-verification-function* string) + (unless (or res flag) (editor-error)) + (exit-recursive-edit res)))) + +(defcommand "Previous Parse" (p) + "Rotate the echo-area history forward. + If current input is non-empty and different from what is on the top + of the ring then push it on the ring before inserting the new input." + "Pop the *echo-area-history* ring buffer." + (let ((length (ring-length *echo-area-history*)) + (p (or p 1))) + (declare (simple-string current)) + (when (zerop length) (editor-error)) + (cond + ((eq (last-command-type) :echo-history) + (let ((base (mod (+ *echo-history-pointer* p) length))) + (delete-region *parse-input-region*) + (insert-string (region-end *parse-input-region*) + (ring-ref *echo-area-history* base)) + (setq *echo-history-pointer* base))) + (t + (let ((current (region-to-string *parse-input-region*)) + (base (mod (if (minusp p) p (1- p)) length))) + (delete-region *parse-input-region*) + (insert-string (region-end *parse-input-region*) + (ring-ref *echo-area-history* base)) + (when (and (plusp (length current)) + (string/= (ring-ref *echo-area-history* 0) current)) + (ring-push current *echo-area-history*) + (incf base)) + (setq *echo-history-pointer* base)))) + (setf (last-command-type) :echo-history))) + +(defcommand "Next Parse" (p) + "Rotate the echo-area history backward. + If current input is non-empty and different from what is on the top + of the ring then push it on the ring before inserting the new input." + "Push the *echo-area-history* ring buffer." + (previous-parse-command (- (or p 1)))) + +(defcommand "Illegal" (p) + "This signals an editor-error. + It is useful for making commands locally unbound." + "Just signals an editor-error." + (declare (ignore p)) + (editor-error)) + +(defcommand "Beginning Of Parse" (p) + "Moves to immediately after the prompt when in the echo area." + "Move the point of the echo area buffer to *parse-starting-mark*." + (declare (ignore p)) + (move-mark (buffer-point *echo-area-buffer*) *parse-starting-mark*)) + +(defcommand "Echo Area Delete Previous Character" (p) + "Delete the previous character. + Don't let the luser rub out the prompt." + "Signal an editor-error if we would nuke the prompt, + otherwise do a normal delete." + (with-mark ((tem (buffer-point *echo-area-buffer*))) + (unless (character-offset tem (- (or p 1))) (editor-error)) + (when (mark< tem *parse-starting-mark*) (editor-error)) + (delete-previous-character-command p))) + +(defcommand "Echo Area Kill Previous Word" (p) + "Kill the previous word. + Don't let the luser rub out the prompt." + "Signal an editor-error if we would mangle the prompt, otherwise + do a normal kill-previous-word." + (with-mark ((tem (buffer-point *echo-area-buffer*))) + (unless (word-offset tem (- (or p 1))) (editor-error)) + (when (mark< tem *parse-starting-mark*) (editor-error)) + (kill-previous-word-command p))) + +(proclaim '(special *kill-ring*)) + +(defcommand "Kill Parse" (p) + "Kills any input so far." + "Kills *parse-input-region*." + (declare (ignore p)) + (if (end-line-p (current-point)) + (kill-region *parse-input-region* :kill-backward) + (ring-push (delete-and-save-region *parse-input-region*) + *kill-ring*))) + +(defcommand "Insert Parse Default" (p) + "Inserts the default for the parse in progress. + The text is inserted at the point." + "Inserts *parse-default* at the point of the *echo-area-buffer*. + If there is no default an editor-error is signalled." + (declare (ignore p)) + (unless *parse-default* (editor-error)) + (insert-string (buffer-point *echo-area-buffer*) *parse-default*)) + +(defcommand "Echo Area Backward Character" (p) + "Go back one character. + Don't let the luser move into the prompt." + "Signal an editor-error if we try to go into the prompt, otherwise + do a backward-character command." + (backward-character-command p) + (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*) + (beginning-of-parse-command ()) + (editor-error))) + +(defcommand "Echo Area Backward Word" (p) + "Go back one word. + Don't let the luser move into the prompt." + "Signal an editor-error if we try to go into the prompt, otherwise + do a backward-word command." + (backward-word-command p) + (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*) + (beginning-of-parse-command ()) + (editor-error))) diff --git a/hemlock/eval-server.lisp b/hemlock/eval-server.lisp new file mode 100644 index 0000000000000000000000000000000000000000..00b18161aaed5df926a478f691adf33a67037737 --- /dev/null +++ b/hemlock/eval-server.lisp @@ -0,0 +1,981 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains code for connecting to eval servers and some command +;;; level stuff too. +;;; +;;; Written by William Lott. +;;; + +(in-package "HEMLOCK") + + + +;;;; Structures. + +(defstruct (server-info (:print-function print-server-info)) + name ; String name of this server. + wire ; Wire connected to this server. + notes ; List of note objects for operations + ; which have not yet completed. + slave-info ; Ts-Info used in "Slave Lisp" buffer + ; (formerly the "Lisp Listener" buffer). + slave-buffer ; "Slave Lisp" buffer for slave's *terminal-io*. + background-info ; Ts-Info structure of typescript we use in + ; "background" buffer. + background-buffer ; Buffer "background" typescript is in. + (errors ; Array of errors while compiling + (make-array 16 + :adjustable t + :fill-pointer 0)) + error-index) ; Index of current error. +;;; +(defun print-server-info (obj stream n) + (declare (ignore n)) + (format stream "#<Server-info for ~A>" (server-info-name obj))) + + +(defstruct (error-info (:print-function print-error-info)) + buffer ; Buffer this error is for. + message ; Error Message + line ; Pointer to message in log buffer. + region) ; Region of faulty text +;;; +(defun print-error-info (obj stream n) + (declare (ignore n)) + (format stream "#<Error: ~A>" (error-info-message obj))) + + +(defvar *server-names* (make-string-table) + "A string-table of the name of all Eval servers and their corresponding + server-info structures.") + +(defvar *abort-operations* nil + "T iff we should ignore any operations sent to us.") + +(defvar *inside-operation* nil + "T iff we are currenly working on an operation. A catcher for the tag + abort-operation will be established whenever this is T.") + +(defconstant *slave-connect-wait* 300) + +;;; Used internally for communications. +;;; +(defvar *newly-created-slave* nil) +(defvar *compiler-wire* nil) +(defvar *compiler-error-stream* nil) +(defvar *compiler-note* nil) + + + +;;;; Hemlock Variables + +(defhvar "Current Eval Server" + "The Server-Info object for the server currently used for evaluation and + compilation." + :value nil) + +(defhvar "Current Compile Server" + "The Server-Info object for the server currently used for compilation + requests." + :value nil) + +(defhvar "Current Package" + "This variable holds the name of the package currently used for Lisp + evaluation and compilation. If it is Nil, the value of *Package* is used + instead." + :value nil) + +(defhvar "Slave Utility" + "This is the pathname of the utility to fire up slave Lisps. It defaults + to /usr/misc/.lisp/bin/lisp." + :value "/usr/misc/.lisp/bin/lisp") + +(defhvar "Slave Utility Switches" + "These are additional switches to pass to the Slave Utility. + For example, (list \"-core\" <core-file-name>). The -slave + switch and the editor name are always supplied, and they should + not be present in this variable." + :value nil) + +(defhvar "Ask About Old Servers" + "When set (the default), Hemlock will prompt for an existing server's name + in preference to prompting for a new slave's name and creating it." + :value t) + +(defhvar "Confirm Slave Creation" + "When set (the default), Hemlock always confirms a slave's creation for + whatever reason." + :value t) + + + +;;;; Slave destruction. + +;;; WIRE-DIED -- Internal. +;;; +;;; The routine is called whenever a wire dies. We roll through all the +;;; servers looking for any that use this wire and nuke them with server-died. +;;; +(defun wire-died (wire) + (let ((servers nil)) + (do-strings (name info *server-names*) + (declare (ignore name)) + (when (eq wire (server-info-wire info)) + (push info servers))) + (dolist (server servers) + (server-died server)))) + +;;; SERVER-DIED -- Internal. +;;; +;;; Clean up the server. Remove any references to it from variables, etc. +;;; +(defun server-died (server) + (let ((name (server-info-name server))) + (delete-string name *server-names*) + (message "Server ~A just died." name)) + (when (server-info-wire server) + (let ((fd (wire:wire-fd (server-info-wire server)))) + (system:invalidate-descriptor fd) + (mach:unix-close fd)) + (setf (server-info-wire server) nil)) + (when (server-info-slave-info server) + (ts-buffer-wire-died (server-info-slave-info server)) + (setf (server-info-slave-info server) nil)) + (when (server-info-background-info server) + (ts-buffer-wire-died (server-info-background-info server)) + (setf (server-info-background-info server) nil)) + (clear-server-errors server) + (when (eq server (variable-value 'current-eval-server :global)) + (setf (variable-value 'current-eval-server :global) nil)) + (when (eq server (variable-value 'current-compile-server :global)) + (setf (variable-value 'current-compile-server :global) nil)) + (dolist (buffer *buffer-list*) + (dolist (var '(current-eval-server current-compile-server server-info)) + (when (and (hemlock-bound-p var :buffer buffer) + (eq (variable-value var :buffer buffer) server)) + (delete-variable var :buffer buffer))))) + +;;; SERVER-CLEANUP -- Internal. +;;; +;;; This routine is called as a buffer delete hook. It takes care of any +;;; per-buffer cleanup that is necessary. It clears out all references to the +;;; buffer from server-info structures and that any errors that refer to this +;;; buffer are finalized. +;;; +(defun server-cleanup (buffer) + (let ((info (if (hemlock-bound-p 'server-info :buffer buffer) + (variable-value 'server-info :buffer buffer)))) + (when info + (when (eq buffer (server-info-slave-buffer info)) + (setf (server-info-slave-buffer info) nil) + (setf (server-info-slave-info info) nil)) + (when (eq buffer (server-info-background-buffer info)) + (setf (server-info-background-buffer info) nil) + (setf (server-info-background-info info) nil)))) + (do-strings (string server *server-names*) + (declare (ignore string)) + (clear-server-errors server + #'(lambda (error) + (eq (error-info-buffer error) buffer))))) +;;; +(add-hook delete-buffer-hook 'server-cleanup) + +;;; CLEAR-SERVER-ERRORS -- Public. +;;; +;;; Clears all known errors for the given server and resets it so more can +;;; accumulate. +;;; +(defun clear-server-errors (server &optional test-fn) + "This clears compiler errors for server cleaning up any pointers for GC + purposes and allowing more errors to register." + (let ((array (server-info-errors server)) + (current nil)) + (dotimes (i (fill-pointer array)) + (let ((error (aref array i))) + (when (or (null test-fn) + (funcall test-fn error)) + (let ((region (error-info-region error))) + (when (regionp region) + (delete-mark (region-start region)) + (delete-mark (region-end region)))) + (setf (aref array i) nil)))) + (let ((index (server-info-error-index server))) + (when index + (setf current + (or (aref array index) + (find-if-not #'null array + :from-end t + :end current))))) + (delete nil array) + (setf (server-info-error-index server) + (position current array)))) + + + +;;;; Slave creation. + +;;; INITIALIZE-SERVER-STUFF -- Internal. +;;; +;;; Reinitialize stuff when a core file is saved. +;;; +(defun initialize-server-stuff () + (clrstring *server-names*)) + + +(defvar *editor-name* nil "Name of this editor.") +(defvar *accept-connections* nil + "When set, allow slaves to connect to the editor.") + +;;; GET-EDITOR-NAME -- Internal. +;;; +;;; Pick a name for the editor. Names consist of machine-name:port-number. If +;;; in ten tries we can't get an unused port, choak. We don't save the result +;;; of WIRE:CREATE-REQUEST-SERVER because we don't think the editor needs to +;;; ever kill the request server, and we can always inhibit connection with +;;; "Accept Connections". +;;; +(defun get-editor-name () + (if *editor-name* + *editor-name* + (let ((random-state (make-random-state t))) + (dotimes (tries 10 (error "Could not create an internet listener.")) + (let ((port (+ 2000 (random 10000 random-state)))) + (when (handler-case (wire:create-request-server + port + #'(lambda (wire addr) + (declare (ignore addr)) + (values *accept-connections* + #'(lambda () (wire-died wire))))) + (error () nil)) + (return (setf *editor-name* + (format nil "~A:~D" (machine-instance) port))))))))) + + +;;; MAKE-BUFFERS-FOR-TYPESCRIPT -- Internal. +;;; +;;; This function returns no values because it is called remotely for value by +;;; connecting slaves. Though we know the system will propagate nil back to +;;; the slave, we indicate here that nil is meaningless. +;;; +(defun make-buffers-for-typescript (slave-name background-name) + "Make the interactive and background buffers slave-name and background-name. + If either is nil, then prompt the user." + (multiple-value-bind (slave-name background-name) + (if (and slave-name background-name) + (values slave-name background-name) + (pick-slave-buffer-names)) + (let* ((slave-buffer (or (getstring slave-name *buffer-names*) + (make-buffer slave-name :modes '("Lisp")))) + (background-buffer (or (getstring background-name *buffer-names*) + (make-buffer background-name + :modes '("Lisp")))) + (server-info (make-server-info :name slave-name + :wire wire:*current-wire* + :slave-buffer slave-buffer + :background-buffer background-buffer)) + (slave-info (typescriptify-buffer slave-buffer server-info + wire:*current-wire*)) + (background-info (typescriptify-buffer background-buffer server-info + wire:*current-wire*))) + (setf (server-info-slave-info server-info) slave-info) + (setf (server-info-background-info server-info) background-info) + (setf (getstring slave-name *server-names*) server-info) + (unless (variable-value 'current-eval-server :global) + (setf (variable-value 'current-eval-server :global) server-info)) + (wire:remote-value + wire:*current-wire* + (made-buffers-for-typescript (wire:make-remote-object slave-info) + (wire:make-remote-object background-info))) + (setf *newly-created-slave* server-info) + (values)))) + + +;;; CREATE-SLAVE -- Public. +;;; +(defun create-slave (&optional name) + "This creates a slave that tries to connect to the editor. When the slave + connects to the editor, this returns a slave-information structure. Name is + the name of the interactive buffer. If name is nil, this generates a name. + If name is supplied, and a buffer with that name already exists, this + signals an error. In case the slave never connects, this will eventually + timeout and signal an editor-error." + (when (and name (getstring name *buffer-names*)) + (editor-error "Buffer ~A is already in use." name)) + (multiple-value-bind (slave background) + (if name + (values name (format nil "Background ~A" name)) + (pick-slave-buffer-names)) + (when (value confirm-slave-creation) + (setf slave (prompt-for-string + :prompt "New slave name? " + :help "Enter the name to use for the newly created slave." + :default slave + :default-string slave)) + (setf background (format nil "Background ~A" slave)) + (when (getstring slave *buffer-names*) + (editor-error "Buffer ~A is already in use." slave)) + (when (getstring background *buffer-names*) + (editor-error "Buffer ~A is already in use." background))) + (message "Spawning slave ... ") + (unless (ext:run-program (namestring (truename (value slave-utility))) + `("-slave" ,(get-editor-name) + ,@(if slave (list "-slave-buffer" slave)) + ,@(if background + (list "-background-buffer" background)) + ,@(value slave-utility-switches)) + :wait nil + :output "/dev/null" + :if-output-exists :append) + (editor-error "Could not start slave.")) + (let ((*accept-connections* t) + (*newly-created-slave* nil)) + (dotimes (i *slave-connect-wait* + (editor-error "Client Lisp is still unconnected. ~ + You must use \"Accept Slave Connections\" to ~ + allow the slave to connect at this point.")) + (system:serve-event 1) + (when *newly-created-slave* + (message "DONE") + (return *newly-created-slave*)))))) + +;;; MAYBE-CREATE-SERVER -- Internal interface. +;;; +(defun maybe-create-server () + "If there is an existing server and \"Ask about Old Servers\" is set, then + prompt for a server's name and return that server's info. Otherwise, + create a new server." + (if (value ask-about-old-servers) + (multiple-value-bind (first-server-name first-server-info) + (do-strings (name info *server-names*) + (return (values name info))) + (if first-server-info + (multiple-value-bind + (name info) + (prompt-for-keyword (list *server-names*) + :prompt "Existing server name: " + :default first-server-name + :default-string first-server-name + :help + "Enter the name of an existing eval server." + :must-exist t) + (declare (ignore name)) + (or info (create-slave))) + (create-slave))) + (create-slave))) + + +(defvar *next-slave-index* 0 + "Number to use when creating the next slave.") + +;;; PICK-SLAVE-BUFFER-NAMES -- Internal. +;;; +;;; Return two unused names to use for the slave and background buffers. +;;; +(defun pick-slave-buffer-names () + (loop + (let ((slave (format nil "Slave ~D" (incf *next-slave-index*))) + (background (format nil "Background Slave ~D" *next-slave-index*))) + (unless (or (getstring slave *buffer-names*) + (getstring background *buffer-names*)) + (return (values slave background)))))) + + + +;;;; Slave selection. + +;;; GET-CURRENT-EVAL-SERVER -- Public. +;;; +(defun get-current-eval-server (&optional errorp) + "Returns the server-info struct for the current eval server. If there is + none, and errorp is non-nil, then signal an editor error. If there is no + current server, and errorp is nil, then create one, prompting the user for + confirmation. Also, set the current server to be the newly created one." + (let ((info (value current-eval-server))) + (cond (info) + (errorp + (editor-error "No current eval server.")) + (t + (setf (value current-eval-server) (maybe-create-server)))))) + +;;; GET-CURRENT-COMPILE-SERVER -- Public. +;;; +;;; If a current compile server is defined, return it, otherwise return the +;;; current eval server using get-current-eval-server. +;;; +(defun get-current-compile-server (&optional errorp) + "Returns the server-info struct for the current compile server. If there is + no current compile server, return the current eval server." + (or (value current-compile-server) + (get-current-eval-server errorp))) + + + +;;;; Server Manipulation commands. + +(defcommand "Select Slave" (p) + "Switch to the current slave's buffer. When given an argument, create a new + slave." + "Switch to the current slave's buffer. When given an argument, create a new + slave." + (let* ((info (if p (create-slave) (get-current-eval-server))) + (slave (server-info-slave-buffer info))) + (unless slave + (editor-error "The current eval server doesn't have a slave buffer!")) + (change-to-buffer slave))) + +(defcommand "Select Background" (p) + "Switch to the current slave's background buffer. When given an argument, use + the current compile server instead of the current eval server." + "Switch to the current slave's background buffer. When given an argument, use + the current compile server instead of the current eval server." + (let* ((info (if p + (get-current-compile-server t) + (get-current-eval-server t))) + (background (server-info-background-buffer info))) + (unless background + (editor-error "The current ~A server doesn't have a background buffer!" + (if p "compile" "eval"))) + (change-to-buffer background))) + +(defcommand "Kill Slave" (p) + "This aborts any operations in the slave, tells the slave to QUIT, and shuts + down the connection to the specified eval server. This makes no attempt to + assure the eval server actually dies." + "This aborts any operations in the slave, tells the slave to QUIT, and shuts + down the connection to the specified eval server. This makes no attempt to + assure the eval server actually dies." + (declare (ignore p)) + (let ((default (and (value current-eval-server) + (server-info-name (value current-eval-server))))) + (multiple-value-bind + (name info) + (prompt-for-keyword + (list *server-names*) + :prompt "Kill Slave: " + :help "Enter the name of the eval server you wish to destroy." + :must-exist t + :default default + :default-string default) + (declare (ignore name)) + (let ((wire (server-info-wire info))) + (when wire + (ext:send-character-out-of-band (wire:wire-fd wire) #\N) + (wire:remote wire (ext:quit)) + (wire:wire-force-output wire))) + (server-died info)))) + +(defcommand "Kill Slave and Buffers" (p) + "This is the same as \"Kill Slave\", but it also deletes the slaves + interaction and background buffers." + "This is the same as \"Kill Slave\", but it also deletes the slaves + interaction and background buffers." + (declare (ignore p)) + (let ((default (and (value current-eval-server) + (server-info-name (value current-eval-server))))) + (multiple-value-bind + (name info) + (prompt-for-keyword + (list *server-names*) + :prompt "Kill Slave: " + :help "Enter the name of the eval server you wish to destroy." + :must-exist t + :default default + :default-string default) + (declare (ignore name)) + (let ((wire (server-info-wire info))) + (when wire + (ext:send-character-out-of-band (wire:wire-fd wire) #\N) + (wire:remote wire (ext:quit)) + (wire:wire-force-output wire))) + (let ((buffer (server-info-slave-buffer info))) + (when buffer (delete-buffer-if-possible buffer))) + (let ((buffer (server-info-background-buffer info))) + (when buffer (delete-buffer-if-possible buffer))) + (server-died info)))) + +(defcommand "Accept Slave Connections" (p) + "This causes Hemlock to accept slave connections and displays the port of + the editor's connections request server. This is suitable for use with the + Lisp's -slave switch. Given an argument, this inhibits slave connections." + "This causes Hemlock to accept slave connections and displays the port of + the editor's connections request server. This is suitable for use with the + Lisp's -slave switch. Given an argument, this inhibits slave connections." + (let ((accept (not p))) + (setf *accept-connections* accept) + (message "~:[Inhibiting~;Accepting~] connections to ~S" + accept (get-editor-name)))) + + + +;;;; Slave initialization junk. + +(defvar *original-beep-function* nil + "Handle on original beep function.") + +(defvar *original-gc-notify-before* nil + "Handle on original before-GC notification function.") + +(defvar *original-gc-notify-after* nil + "Handle on original after-GC notification function.") + +(defvar *original-terminal-io* nil + "Handle on original *terminal-io* so we can restore it.") + +(defvar *original-standard-input* nil + "Handle on original *standard-input* so we can restore it.") + +(defvar *original-standard-output* nil + "Handle on original *standard-output* so we can restore it.") + +(defvar *original-error-output* nil + "Handle on original *error-output* so we can restore it.") + +(defvar *original-debug-io* nil + "Handle on original *debug-io* so we can restore it.") + +(defvar *original-query-io* nil + "Handle on original *query-io* so we can restore it.") + +(defvar *original-trace-output* nil + "Handle on original *trace-output* so we can restore it.") + +(defvar *background-io* nil + "Stream connected to the editor's background buffer in case we want to use it + in the future.") + +;;; CONNECT-STREAM -- internal +;;; +;;; Run in the slave to create a new stream and connect it to the supplied +;;; buffer. Returns the stream. +;;; +(defun connect-stream (remote-buffer) + (let ((stream (make-ts-stream wire:*current-wire* remote-buffer))) + (wire:remote wire:*current-wire* + (ts-buffer-set-stream remote-buffer + (wire:make-remote-object stream))) + stream)) + +;;; MADE-BUFFERS-FOR-TYPESCRIPT -- Internal Interface. +;;; +;;; Run in the slave by the editor with the two buffers' info structures, +;;; actually remote-objects in the slave. Does any necessary stream hacking. +;;; Return nil to make sure no weird objects try to go back over the wire +;;; since the editor calls this in the slave for value. The editor does this +;;; for synch'ing, not for values. +;;; +(defun made-buffers-for-typescript (slave-info background-info) + (macrolet ((frob (symbol new-value) + `(setf ,(intern (concatenate 'simple-string + "*ORIGINAL-" + (subseq (string symbol) 1))) + ,symbol + ,symbol ,new-value))) + (let ((wire wire:*current-wire*)) + (frob system:*beep-function* + #'(lambda (&optional stream) + (declare (ignore stream)) + (wire:remote-value wire (beep)))) + (frob ext:*gc-notify-before* + #'(lambda (bytes-in-use) + (wire:remote wire + (slave-gc-notify-before + slave-info + (format nil + "~%[GC threshold exceeded with ~:D bytes in use. ~ + Commencing GC.]~%" + bytes-in-use))) + (wire:wire-force-output wire))) + (frob ext:*gc-notify-after* + #'(lambda (bytes-retained bytes-freed new-trigger) + (wire:remote wire + (slave-gc-notify-after + slave-info + (format nil + "[GC completed with ~:D bytes retained and ~:D ~ + bytes freed.]~%[GC will next occur when at least ~ + ~:D bytes are in use.]~%" + bytes-retained bytes-freed new-trigger))) + (wire:wire-force-output wire)))) + (frob *terminal-io* (connect-stream slave-info)) + (frob *standard-input* (make-synonym-stream '*terminal-io*)) + (frob *standard-output* *standard-input*) + (frob *error-output* *standard-input*) + (frob *debug-io* *standard-input*) + (frob *query-io* *standard-input*) + (frob *trace-output* *standard-input*)) + (setf *background-io* (connect-stream background-info)) + nil) + +;;; SLAVE-GC-NOTIFY-BEFORE and SLAVE-GC-NOTIFY-AFTER -- internal +;;; +;;; These two routines are run in the editor by the slave's gc notify routines. +;;; +(defun slave-gc-notify-before (remote-ts message) + (let ((ts (wire:remote-object-value remote-ts))) + (ts-buffer-output-string ts message t) + (message "~A is GC'ing." (buffer-name (ts-data-buffer ts))) + (system:beep))) +(defun slave-gc-notify-after (remote-ts message) + (let ((ts (wire:remote-object-value remote-ts))) + (ts-buffer-output-string ts message t) + (message "~A is done GC'ing." (buffer-name (ts-data-buffer ts))) + (system:beep))) + +;;; EDITOR-DIED -- internal +;;; +;;; Run in the slave when the editor goes belly up. +;;; +(defun editor-died () + (macrolet ((frob (symbol) + (let ((orig (intern (concatenate 'simple-string + "*ORIGINAL-" + (subseq (string symbol) 1))))) + `(when ,orig + (setf ,symbol ,orig))))) + (frob system:*beep-function*) + (frob ext:*gc-notify-before*) + (frob ext:*gc-notify-after*) + (frob *terminal-io*) + (frob *standard-input*) + (frob *standard-output*) + (frob *error-output*) + (frob *debug-io*) + (frob *query-io*) + (frob *trace-output*)) + (setf *background-io* nil) + (format t "~2&Connection to editor died.~%") + (ext:quit)) + +;;; START-SLAVE -- internal +;;; +;;; Initiate the process by which a lisp becomes a slave. +;;; +(defun start-slave (editor) + (declare (simple-string editor)) + (let ((seperator (position #\: editor :test #'char=))) + (unless seperator + (error "Editor name ~S invalid. ~ + Must be of the form \"MachineName:PortNumber\"." + editor)) + (let ((machine (subseq editor 0 seperator)) + (port (parse-integer editor :start (1+ seperator)))) + (format t "Connecting to ~A:~D~%" machine port) + (connect-to-editor machine port)))) + +;;; CONNECT-TO-EDITOR -- internal +;;; +;;; Do the actual connect to the editor. +;;; +(defun connect-to-editor (machine port + &optional + (slave (find-eval-server-switch "slave-buffer")) + (background (find-eval-server-switch + "background-buffer"))) + (let ((wire (wire:connect-to-remote-server machine port 'editor-died))) + (ext:add-oob-handler (wire:wire-fd wire) + #\B + #'(lambda () + (system:without-hemlock + (system:with-interrupts + (break "Software Interrupt"))))) + (ext:add-oob-handler (wire:wire-fd wire) + #\T + #'(lambda () + (when lisp::*in-top-level-catcher* + (throw 'lisp::top-level-catcher nil)))) + (ext:add-oob-handler (wire:wire-fd wire) + #\A + #'abort) + (ext:add-oob-handler (wire:wire-fd wire) + #\N + #'(lambda () + (setf *abort-operations* t) + (when *inside-operation* + (throw 'abort-operation + (if debug::*in-the-debugger* + :was-in-debugger))))) + (wire:remote-value wire + (make-buffers-for-typescript slave background)))) + + +;;;; Eval server evaluation functions. + +(defvar *eval-form-stream* + (make-two-way-stream + (lisp::make-stream + :in #'(lambda (&rest junk) + (declare (ignore junk)) + (error "You cannot read when handling an eval_form request."))) + (make-broadcast-stream))) + +;;; SERVER-EVAL-FORM -- Public. +;;; Evaluates the given form (which is a string to be read from in the given +;;; package) and returns the results as a list. +;;; +(defun server-eval-form (package form) + (declare (simple-string package form)) + (handler-bind + ((error #'(lambda (condition) + (wire:remote wire:*current-wire* + (eval-form-error (format nil "~A~&" condition))) + (return-from server-eval-form nil)))) + (let ((*package* (if package + (lisp::package-or-lose package) + *package*)) + (*terminal-io* *eval-form-stream*)) + (stringify-list (multiple-value-list (eval (read-from-string form))))))) + + +;;; DO-OPERATION -- Internal. +;;; Checks to see if we are aborting operations. If not, do the operation +;;; wrapping it with operation-started and operation-completed calls. Also +;;; deals with setting up *terminal-io* and *package*. +;;; +(defmacro do-operation ((note package terminal-io) &body body) + `(let ((aborted t) + (*terminal-io* (if ,terminal-io + (wire:remote-object-value ,terminal-io) + *terminal-io*)) + (*package* (maybe-make-package ,package))) + (unwind-protect + (unless *abort-operations* + (when (eq :was-in-debugger + (catch 'abort-operation + (let ((*inside-operation* t)) + (wire:remote wire:*current-wire* + (operation-started ,note)) + (wire:wire-force-output wire:*current-wire*) + ,@body + (setf aborted nil)))) + (format t + "~&[Operation aborted. ~ + You are no longer in this instance of the debugger.]~%"))) + (wire:remote wire:*current-wire* + (operation-completed ,note aborted)) + (wire:wire-force-output wire:*current-wire*)))) + + +;;; unique-thingie is a unique eof-value for READ'ing. Its a parameter, so +;;; we can reload the file. +;;; +(defparameter unique-thingie (gensym) + "Used as eof-value in reads to check for the end of a file.") + +;;; SERVER-EVAL-TEXT -- Public. +;;; +;;; Evaluate all the forms read from text in the given package, and send the +;;; results back. The error handler bound does not handle any errors. It +;;; simply notifies the client that an error occurred and then returns. +;;; +(defun server-eval-text (note package text terminal-io) + (do-operation (note package terminal-io) + (with-input-from-string (stream text) + (let ((last-pos 0)) + (handler-bind + ((error + #'(lambda (condition) + (wire:remote wire:*current-wire* + (lisp-error note last-pos + (file-position stream) + (format nil "~A~&" condition)))))) + (loop + (let ((form (read stream nil unique-thingie))) + (when (eq form unique-thingie) + (return nil)) + (let* ((values (stringify-list (multiple-value-list (eval form)))) + (pos (file-position stream))) + (wire:remote wire:*current-wire* + (eval-text-result note last-pos pos values)) + (setf last-pos pos))))))))) + +(defun stringify-list (list) + (mapcar #'prin1-to-string list)) +#| +(defun stringify-list (list) + (mapcar #'(lambda (thing) + (with-output-to-string (stream) + (write thing + :stream stream :radix nil :base 10 :circle t + :pretty nil :level nil :length nil :case :upcase + :array t :gensym t))) + list)) +|# + + +;;;; Eval server compilation stuff. + +;;; DO-COMPILER-OPERATION -- Internal. +;;; +;;; Useful macro that does the operation with *compiler-note* and +;;; *compiler-wire* bound. +;;; +(defmacro do-compiler-operation ((note package terminal-io error) &body body) + `(let ((*compiler-note* ,note) + (*compiler-error-stream* ,error) + (*compiler-wire* wire:*current-wire*) + (clc:*compiler-notification-function* #'compiler-note-in-editor)) + (do-operation (*compiler-note* ,package ,terminal-io) + (unwind-protect + (handler-bind ((error #'compiler-error-handler)) + ,@body) + (when *compiler-error-stream* + (force-output *compiler-error-stream*)))))) + +;;; COMPILER-NOTIFICATION -- Internal. +;;; +;;; DO-COMPILER-OPERATION binds clc:*compiler-notification-function to this, so +;;; interesting observations in the compilation can be propagated back to the +;;; editor. If there is a notification point defined, we send information +;;; about the position and kind of error. The actual error text is written out +;;; using typescript operations. +;;; +;;; Start and End are the compiler's best guess at the file position where the +;;; error occurred. Function is the symbolic name of the function in which the +;;; error occurred. We PRIN1 this to a string because sending the symbol back +;;; to the editor could easily result in the editor trying to fetch a symbol +;;; off the wire into a non-existing package. We expect packages to exist in +;;; the developing Lisp environment that are missing in the editor's Lisp. +;;; +(defun compiler-note-in-editor (severity function) + (when *compiler-wire* + (force-output *compiler-error-stream*) + (multiple-value-bind (start end) + (clc:current-form-position) + (wire:remote *compiler-wire* + (compiler-error *compiler-note* start end + (prin1-to-string function) + severity))) + (wire:wire-force-output *compiler-wire*))) + +;;; COMPILER-ERROR-HANDLER -- Internal. +;;; +;;; The error handler function for the compiler interfaces. +;;; DO-COMPILER-OPERATION binds this as an error handler while evaluating the +;;; compilation form. +;;; +(defun compiler-error-handler (condition) + (when *compiler-wire* + (multiple-value-bind (start end) + (clc:current-form-position) + (wire:remote *compiler-wire* + (lisp-error *compiler-note* start end + (format nil "~A~&" condition)))))) + + + + +;;; SERVER-COMPILE-TEXT -- Public. +;;; +;;; Similar to server-eval-text, except that the stuff is compiled. +;;; +(defun server-compile-text (note package text defined-from + terminal-io error-output) + (let ((error-output (if error-output + (wire:remote-object-value error-output)))) + (do-compiler-operation (note package terminal-io error-output) + (with-input-from-string (input-stream text) + (terpri error-output) + (compile-from-stream input-stream + :error-stream error-output + :defined-from-pathname defined-from))))) + +;;; SERVER-COMPILE-FILE -- Public. +;;; +;;; Compiles the file sending error info back to the editor. +;;; +(defun server-compile-file (note package input output error lap + load terminal background) + (macrolet ((frob (x) + `(if (wire:remote-object-p ,x) + (wire:remote-object-value ,x) + ,x))) + (let ((error-stream (frob background))) + (do-compiler-operation (note package terminal error-stream) + (compile-file (frob input) + :output-file (frob output) + :error-file (frob error) + :lap-file (frob lap) + :load load + :errors-to-terminal error-stream))))) + + +;;;; Other random eval server stuff. + +;;; MAYBE-MAKE-PACKAGE -- Internal. +;;; +;;; Returns a package for a name. Creates it if it doesn't already exist. +;;; +(defun maybe-make-package (name) + (cond ((null name) *package*) + ((find-package name)) + (t + (wire:remote-value (ts-stream-wire *terminal-io*) + (ts-buffer-output-string + (ts-stream-typescript *terminal-io*) + (format nil "~&Creating package ~A.~%" name) + t)) + (make-package name)))) + +;;; SERVER-SET-PACKAGE -- Public. +;;; +;;; Serves package setting requests. It simply sets +;;; *package* to an already existing package or newly created one. +;;; +(defun server-set-package (package) + (setf *package* (maybe-make-package package))) + +;;; SERVER-ACCEPT-OPERATIONS -- Public. +;;; +;;; Start accepting operations again. +;;; +(defun server-accept-operations () + (setf *abort-operations* nil)) + + + +;;;; Command line switches. + +;;; FIND-EVAL-SERVER-SWITCH -- Internal. +;;; +;;; This is special to the switches supplied by CREATE-SLAVE and fetched by +;;; CONNECT-EDITOR-SERVER, so we can use STRING=. +;;; +(defun find-eval-server-switch (string) + (let ((switch (find string ext:*command-line-switches* + :test #'string= + :key #'ext:cmd-switch-name))) + (if switch + (or (ext:cmd-switch-value switch) + (car (ext:cmd-switch-words switch)))))) + + +(defun slave-switch-demon (switch) + (let ((editor (ext:cmd-switch-arg switch))) + (unless editor + (error "Editor to connect to unspesified.")) + (start-slave editor))) +;;; +(defswitch "slave" 'slave-switch-demon) +(defswitch "slave-buffer") +(defswitch "background-buffer") + + +(defun edit-switch-demon (switch) + (declare (ignore switch)) +#| (let ((arg (or (ext:cmd-switch-value switch) + (car (ext:cmd-switch-words switch))))) + (when (stringp arg) (setq *editor-name* arg)))|# + (let ((initp (not (ext:get-command-line-switch "noinit")))) + (if (stringp (car ext:*command-line-words*)) + (ed (car ext:*command-line-words*) :init initp) + (ed nil :init initp)))) +;;; +(defswitch "edit" 'edit-switch-demon) diff --git a/hemlock/filecoms.lisp b/hemlock/filecoms.lisp new file mode 100644 index 0000000000000000000000000000000000000000..443c9c0895c7e36258e2569ac414acf4b6f05656 --- /dev/null +++ b/hemlock/filecoms.lisp @@ -0,0 +1,1039 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains file/buffer manipulating commands. +;;; +(in-package "HEMLOCK") + + + +;;;; PROCESS-FILE-OPTIONS. + +(defvar *mode-option-handlers* () + "Do not modify this; use Define-File-Option instead.") + +(defvar *file-type-hooks* () + "Do not modify this; use Define-File-Type-Hook instead.") + +(defun trim-subseq (string start end) + (declare (simple-string string)) + (string-trim '(#\Space #\Tab) (subseq string start end))) + +;;; PROCESS-FILE-OPTIONS checks the first line of buffer for the file options +;;; indicator "-*-". IF it finds this, then it enters a do-file-options block. +;;; If any parsing errors occur while picking out options, we return from this +;;; block. Staying inside this function at this point, allows us to still set +;;; a major mode if no file option specified one. +;;; +;;; We also cater to old style mode comments: +;;; -*- Lisp -*- +;;; -*- Text -*- +;;; This kicks in if we find no colon on the file options line. +;;; +(defun process-file-options (buffer &optional + (pathname (buffer-pathname buffer))) + "Checks for file options and invokes handlers if there are any. If no + \"Mode\" mode option is specified, then this tries to invoke the appropriate + file type hook." + (let* ((string + (line-string (mark-line (buffer-start-mark buffer)))) + (found (search "-*-" string)) + (no-major-mode t) + (type (if pathname (pathname-type pathname)))) + (declare (simple-string string)) + (when found + (block do-file-options + (let* ((start (+ found 3)) + (end (search "-*-" string :start2 start))) + (unless end + (loud-message "No closing \"-*-\". Aborting file options.") + (return-from do-file-options)) + (cond + ((find #\: string :start start :end end) + (do ((opt-start start (1+ semi)) colon semi) + (nil) + (setq colon (position #\: string :start opt-start :end end)) + (unless colon + (loud-message "Missing \":\". Aborting file options.") + (return-from do-file-options)) + (setq semi (or (position #\; string :start colon :end end) end)) + (let* ((option (nstring-downcase + (trim-subseq string opt-start colon))) + (handler (assoc option *mode-option-handlers* + :test #'string=))) + (declare (simple-string option)) + (cond + (handler + (let ((result (funcall (cdr handler) buffer + (trim-subseq string (1+ colon) semi)))) + (when (string= option "mode") + (setq no-major-mode (not result))))) + (t (message "Unknown file option: ~S" option))) + (when (= semi end) (return nil))))) + (t + ;; Old style mode comment. + (setq no-major-mode nil) + (funcall (cdr (assoc "mode" *mode-option-handlers* :test #'string=)) + buffer (trim-subseq string start end))))))) + (when (and no-major-mode type) + (let ((hook (assoc (string-downcase type) *file-type-hooks* + :test #'string=))) + (when hook (funcall (cdr hook) buffer type)))))) + + + +;;;; File options and file type hooks. + +(defmacro define-file-option (name lambda-list &body body) + "Define-File-Option Name (Buffer Value) {Form}* + Defines a new file option to be user in the -*- line at the top of a file. + The body is evaluated with Buffer bound to the buffer the file has been read + into and Value to the string argument to the option." + (let ((name (string-downcase name))) + `(setf (cdr (or (assoc ,name *mode-option-handlers* :test #'string=) + (car (push (cons ,name nil) *mode-option-handlers*)))) + #'(lambda ,lambda-list ,@body)))) + +(define-file-option "Mode" (buffer str) + (let ((seen-major-mode-p nil) + (lastpos 0)) + (loop + (let* ((pos (position #\, str :start lastpos)) + (substr (trim-subseq str lastpos pos))) + (cond ((getstring substr *mode-names*) + (cond ((mode-major-p substr) + (when seen-major-mode-p + (loud-message + "Major mode already processed. Using ~S now." + substr)) + (setf seen-major-mode-p t) + (setf (buffer-major-mode buffer) substr)) + (t + (setf (buffer-minor-mode buffer substr) t)))) + (t + (loud-message "~S is not a defined mode -- ignored." substr))) + (unless pos + (return seen-major-mode-p)) + (setf lastpos (1+ pos)))))) + + +(defmacro define-file-type-hook (type-list (buffer type) &body body) + "Define-File-Type-Hook ({Type}*) (Buffer Type) {Form}* + Define some code to be evaluated when a file having one of the specified + Types is read by a file command. Buffer is bound to the buffer the + file is in, and Type is the actual type read." + (let ((fun (gensym)) (str (gensym))) + `(flet ((,fun (,buffer ,type) ,@body)) + (dolist (,str ',(mapcar #'string-downcase type-list)) + (setf (cdr (or (assoc ,str *file-type-hooks* :test #'string=) + (car (push (cons ,str nil) *file-type-hooks*)))) + #',fun))))) + +(define-file-type-hook ("pas" "pasmac" "macro" "defs" "spc" "bdy") + (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Pascal")) + +(define-file-type-hook ("lisp" "slisp" "l" "lsp" "mcl") (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Lisp")) + +(define-file-type-hook ("txt" "text" "tx") (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Text")) + + + +;;;; Support for file hacking commands: + +(defhvar "Pathname Defaults" + "This variable contains a pathname which is used to supply defaults + when we don't have anything better." + :value (pathname "gazonk.del")) + +(defhvar "Last Resort Pathname Defaults" + "This variable contains a pathname which is used to supply defaults when + we don't have anything better, but unlike \"Pathname Defaults\", this is + never set to some buffer's pathname." + :value (pathname "gazonk")) + +(defhvar "Last Resort Pathname Defaults Function" + "This variable contains a function that is called when a default pathname is + needed, the buffer has no pathname, and the buffer's name is not entirely + composed of alphanumerics. The default value is a function that simply + returns \"Last Resort Pathname Defaults\". The function must take a buffer + as an argument, and it must return some pathname." + :value #'(lambda (buffer) + (declare (ignore buffer)) + (merge-pathnames (value last-resort-pathname-defaults) + (value pathname-defaults)))) + +(defun buffer-default-pathname (buffer) + "Returns \"Buffer Pathname\" if it is bound. If it is not, and buffer's name + is composed solely of alphnumeric characters, then return a pathname formed + from the buffer's name. If the buffer's name has other characters in it, + then return the value of \"Last Resort Pathname Defaults Function\" called + on buffer." + (or (buffer-pathname buffer) + (if (every #'alphanumericp (the simple-string (buffer-name buffer))) + (merge-pathnames (make-pathname :name (buffer-name buffer)) + (value pathname-defaults)) + (funcall (value last-resort-pathname-defaults-function) buffer)))) + + +(defun pathname-to-buffer-name (pathname) + "Returns a simple-string using components from pathname." + (let ((pathname (pathname pathname))) + (concatenate 'simple-string + (file-namestring pathname) + " " + (directory-namestring pathname)))) + + + +;;;; File hacking commands. + +(defcommand "Process File Options" (p) + "Reprocess this buffer's file options." + "Reprocess this buffer's file options." + (declare (ignore p)) + (process-file-options (current-buffer))) + +(defcommand "Insert File" (p &optional pathname (buffer (current-buffer))) + "Inserts a file which is prompted for into the current buffer at the point. + The prefix argument is ignored." + "Inserts the file named by Pathname into Buffer at the point." + (declare (ignore p)) + (let* ((pn (or pathname + (prompt-for-file :default (buffer-default-pathname buffer) + :prompt "Insert File: " + :help "Name of file to insert"))) + (point (buffer-point buffer)) + ;; start and end will be deleted by undo stuff + (start (copy-mark point :right-inserting)) + (end (copy-mark point :left-inserting)) + (region (region start end))) + (setv pathname-defaults pn) + (push-buffer-mark (copy-mark end)) + (read-file pn end) + (make-region-undo :delete "Insert File" region))) + +(defcommand "Write Region" (p &optional pathname) + "Writes the current region to a file. " + "Writes the current region to a file. " + (declare (ignore p)) + (let ((region (current-region)) + (pn (or pathname + (prompt-for-file :prompt "File to Write: " + :help "The name of the file to write the region to. " + :default (buffer-default-pathname + (current-buffer)) + :must-exist nil)))) + (write-file region pn) + (message "~A written." (namestring (truename pn))))) + + + +;;;; Visiting and reverting files. + +(defcommand "Visit File" (p &optional pathname (buffer (current-buffer))) + "Replaces the contents of Buffer with the file Pathname. The prefix + argument is ignored. The buffer is set to be writable, so its region + can be deleted." + "Replaces the contents of the current buffer with the text in the file + which is prompted for. The prefix argument is, of course, ignored p times." + (declare (ignore p)) + (when (and (buffer-modified buffer) + (prompt-for-y-or-n :prompt "Buffer is modified, save it? ")) + (save-file-command () buffer)) + (let ((pn (or pathname + (prompt-for-file :prompt "Visit File: " + :must-exist nil + :help "Name of file to visit." + :default (buffer-default-pathname buffer))))) + (setf (buffer-writable buffer) t) + (read-buffer-file pn buffer) + (let ((n (pathname-to-buffer-name (buffer-pathname buffer)))) + (unless (getstring n *buffer-names*) + (setf (buffer-name buffer) n)) + (warn-about-visit-file-buffers buffer)))) + +(defun warn-about-visit-file-buffers (buffer) + (let ((buffer-pn (buffer-pathname buffer))) + (dolist (b *buffer-list*) + (unless (eq b buffer) + (let ((bpn (buffer-pathname b))) + (when (equal bpn buffer-pn) + (message "Buffer ~A also contains ~A." + (buffer-name b) (namestring buffer-pn)) + (return))))))) + + +(defhvar "Revert File Confirm" + "If this is true, Revert File will prompt before reverting." + :value t) + +(defcommand "Revert File" (p) + "Unless in Save Mode, reads in the last saved version of the file in + the current buffer. When in Save Mode, reads in the last checkpoint or + the last saved version, whichever is more recent. An argument will always + force Revert File to use the last saved version. In either case, if the + buffer has been modified and \"Revert File Confirm\" is true, then Revert + File will ask for confirmation beforehand. An attempt is made to maintain + the point's relative position." + "With an argument reverts to the last saved version of the file in the + current buffer. Without, reverts to the last checkpoint or last saved + version, whichever is more recent." + (let* ((buffer (current-buffer)) + (buffer-pn (buffer-pathname buffer)) + (point (current-point)) + (lines (1- (count-lines (region (buffer-start-mark buffer) point))))) + (multiple-value-bind (revert-pn used-checkpoint) + (if p buffer-pn (revert-pathname buffer)) + (unless revert-pn + (editor-error "No file associated with buffer to revert to!")) + (when (or (not (value revert-file-confirm)) + (not (buffer-modified buffer)) + (prompt-for-y-or-n + :prompt + "Buffer contains changes, are you sure you want to revert? " + :help (list + "Reverting the file will undo any changes by reading in the last ~ + ~:[saved version~;checkpoint file~]." used-checkpoint) + :default t)) + (read-buffer-file revert-pn buffer) + (when used-checkpoint + (setf (buffer-modified buffer) t) + (setf (buffer-pathname buffer) buffer-pn) + (message "Reverted to checkpoint file ~A." (namestring revert-pn))) + (unless (line-offset point lines) + (buffer-end point)))))) + +;;; REVERT-PATHNAME -- Internal +;;; +;;; If in Save Mode, return either the checkpoint pathname or the buffer +;;; pathname whichever is more recent. Otherwise return the buffer-pathname +;;; if it exists. If neither file exists, return NIL. +;;; +(defun revert-pathname (buffer) + (let* ((buffer-pn (buffer-pathname buffer)) + (buffer-pn-date (file-write-date buffer-pn)) + (checkpoint-pn (get-checkpoint-pathname buffer)) + (checkpoint-pn-date (file-write-date checkpoint-pn))) + (cond (checkpoint-pn-date + (if (> checkpoint-pn-date (or buffer-pn-date 0)) + (values checkpoint-pn t) + (values buffer-pn nil))) + (buffer-pn-date (values buffer-pn nil)) + (t (values nil nil))))) + + + +;;;; Find file. + +(defcommand "Find File" (p &optional pathname) + "Visit a file in its own buffer. + If the file is already in some buffer, select that buffer, + otherwise make a new buffer with the same name as the file and + read the file into it." + "Make a buffer containing the file Pathname current, creating a buffer + if necessary. The buffer is returned." + (declare (ignore p)) + (let* ((pn (or pathname + (prompt-for-file + :prompt "Find File: " + :must-exist nil + :help "Name of file to read into its own buffer." + :default (buffer-default-pathname (current-buffer))))) + (buffer (find-file-buffer pn))) + (change-to-buffer buffer) + buffer)) + +(defun find-file-buffer (pathname) + "Return a buffer assoicated with the file Pathname, reading the file into a + new buffer if necessary. The second value is T if we created a buffer, NIL + otherwise. If the file has already been read, we check to see if the file + has been modified on disk since it was read, giving the user various + recovery options." + (let* ((pathname (pathname pathname)) + (trial-pathname (or (probe-file pathname) + (merge-pathnames pathname (default-directory)))) + (found (find trial-pathname (the list *buffer-list*) + :key #'buffer-pathname :test #'equal))) + (cond ((not found) + (let* ((name (pathname-to-buffer-name trial-pathname)) + (buffer (getstring name *buffer-names*)) + (use (if buffer + (prompt-for-buffer + :prompt "Buffer to use: " + :help + "Buffer name in use; give another buffer name, or confirm to reuse." + :default buffer :must-exist nil) + (make-buffer name))) + (buffer (if (stringp use) (make-buffer use) use))) + (when (and (buffer-modified buffer) + (prompt-for-y-or-n :prompt + "Buffer is modified, save it? ")) + (save-file-command () buffer)) + (read-buffer-file pathname buffer) + (values buffer (stringp use)))) + ((check-disk-version-consistent pathname found) + (values found nil)) + (t + (read-buffer-file pathname found) + (values found nil))))) + +;;; Check-Disk-Version-Consistent -- Internal +;;; +;;; Check that Buffer contains a valid version of the file Pathname, +;;; harrassing the user if not. We return true if the buffer is O.K., and +;;; false if the file should be read. +;;; +(defun check-disk-version-consistent (pathname buffer) + (let ((ndate (file-write-date pathname)) + (odate (buffer-write-date buffer))) + (cond ((not (and ndate odate (/= ndate odate))) + t) + ((buffer-modified buffer) + (beep) + (clear-input) + (command-case (:prompt (list + "File has been changed on disk since it was read and you have made changes too!~ + ~%Read in the disk version of ~A? [Y] " (namestring pathname)) + :help + "The file in disk has been changed since Hemlock last saved it, meaning that + someone else has probably overwritten it. Since the version read into Hemlock + has been changed as well, the two versions may have inconsistent changes. If + this is the case, it would be a good idea to save your changes in another file + and compare the two versions. + + Type one of the following commands:") + ((:confirm :yes) + "Prompt for a file to write the buffer out to, then read in the disk version." + (write-buffer-file + buffer + (prompt-for-file + :prompt "File to save changes in: " + :help (list "Save buffer ~S to this file before reading ~A." + (buffer-name buffer) (namestring pathname)) + :must-exist nil + :default (buffer-default-pathname buffer))) + nil) + (:no + "Change to the buffer without reading the new version." + t) + (#\R + "Read in the new version, clobbering the changes in the buffer." + nil))) + (t + (not (prompt-for-yes-or-no :prompt + (list + "File has been changed on disk since it was read.~ + ~%Read in the disk version of ~A? " + (namestring pathname)) + :help + "Type Y to read in the new version or N to just switch to the buffer." + :default t)))))) + + +(defhvar "Read File Hook" + "These functions are called when a file is read into a buffer. Each function + must take two arguments -- the buffer the file was read into and whether the + file existed (non-nil) or not (nil).") + +(defun read-buffer-file (pathname buffer) + "Delete the buffer's region, and uses READ-FILE to read pathname into it. + If the file exists, set the buffer's write date to the file's; otherwise, + MESSAGE that this is a new file and set the buffer's write date to nil. + Move buffer's point to the beginning, set the buffer unmodified. If the + file exists, set the buffer's pathname to the probed pathname; else, set it + to pathname merged with DEFAULT-DIRECTORY. Set \"Pathname Defaults\" to the + same thing. Process the file options, and then invoke \"Read File Hook\"." + (delete-region (buffer-region buffer)) + (let* ((pathname (pathname pathname)) + (probed-pathname (probe-file pathname))) + (cond (probed-pathname + (read-file probed-pathname (buffer-point buffer)) + (setf (buffer-write-date buffer) (file-write-date probed-pathname))) + (t + (message "(New File)") + (setf (buffer-write-date buffer) nil))) + (buffer-start (buffer-point buffer)) + (setf (buffer-modified buffer) nil) + (let ((stored-pathname (or probed-pathname + (merge-pathnames pathname (default-directory))))) + (setf (buffer-pathname buffer) stored-pathname) + (setf (value pathname-defaults) stored-pathname) + (process-file-options buffer stored-pathname) + (invoke-hook read-file-hook buffer probed-pathname)))) + + + +;;;; File writing. + +(defhvar "Add Newline at EOF on Writing File" + "This controls whether WRITE-BUFFER-FILE adds a newline at the end of the + file when it ends at the end of a non-empty line. When set, this may be + :ask-user and WRITE-BUFFER-FILE will prompt; otherwise, just add one and + inform the user. When nil, never add one and don't ask." + :value :ask-user) + +(defhvar "Keep Backup Files" + "When set, .BAK files will be saved upon file writing. This defaults to nil." + :value nil) + +(defhvar "Write File Hook" + "These functions are called when a buffer has been written. Each function + must take the buffer as an argument.") + +(defun write-buffer-file (buffer pathname) + "Write's buffer to pathname. This assumes pathname is somehow related to + the buffer's pathname, and if the buffer's write date is not the same as + pathname's, then this prompts the user for confirmation before overwriting + the file. This consults \"Add Newline at EOF on Writing File\" and + interacts with the user if necessary. This sets \"Pathname Defaults\", and + the buffer is marked unmodified. The buffer's pathname and write date are + updated, and the buffer is renamed according to the new pathname if possible. + This invokes \"Write File Hook\"." + (let ((buffer-pn (buffer-pathname buffer))) + (let ((date (buffer-write-date buffer)) + (file-date (when (probe-file pathname) (file-write-date pathname)))) + (when (and buffer-pn date file-date + (equal (make-pathname :version nil :defaults buffer-pn) + (make-pathname :version nil :defaults pathname)) + (/= date file-date)) + (unless (prompt-for-yes-or-no :prompt (list + "File has been changed on disk since it was read.~%Overwrite ~A anyway? " + (namestring buffer-pn)) + :help + "Type No to abort writing the file or Yes to overwrite the disk version." + :default nil) + (editor-error "Write aborted.")))) + (let ((val (value add-newline-at-eof-on-writing-file))) + (when val + (let ((end (buffer-end-mark buffer))) + (unless (start-line-p end) + (when (if (eq val :ask-user) + (prompt-for-y-or-n + :prompt + (list "~A~%File does not have a newline at EOF, add one? " + (buffer-name buffer)) + :default t) + t) + (insert-character end #\newline) + (message "Added newline at EOF.")))))) + (setv pathname-defaults pathname) + (write-file (buffer-region buffer) pathname) + (let ((tn (truename pathname))) + (message "~A written." (namestring tn)) + (setf (buffer-modified buffer) nil) + (unless (equal tn buffer-pn) + (setf (buffer-pathname buffer) tn)) + (setf (buffer-write-date buffer) (file-write-date tn)) + (let ((name (pathname-to-buffer-name tn))) + (unless (getstring name *buffer-names*) + (setf (buffer-name buffer) name))))) + (invoke-hook write-file-hook buffer)) + +(defcommand "Write File" (p &optional pathname (buffer (current-buffer))) + "Writes the contents of Buffer, which defaults to the current buffer to + the file named by Pathname. The prefix argument is ignored." + "Prompts for a file to write the contents of the current Buffer to. + The prefix argument is ignored." + (declare (ignore p)) + (write-buffer-file + buffer + (or pathname + (prompt-for-file :prompt "Write File: " + :must-exist nil + :help "Name of file to write to" + :default (buffer-default-pathname buffer))))) + +(defcommand "Save File" (p &optional (buffer (current-buffer))) + "Writes the contents of the current buffer to the associated file. If there + is no associated file, once is prompted for." + "Writes the contents of the current buffer to the associated file." + (declare (ignore p)) + (when (or (buffer-modified buffer) + (prompt-for-y-or-n + :prompt "Buffer is unmodified, write it anyway? " + :default t)) + (write-buffer-file + buffer + (or (buffer-pathname buffer) + (prompt-for-file :prompt "Save File: " + :help "Name of file to write to" + :default (buffer-default-pathname buffer) + :must-exist nil))))) + +(defhvar "Save All Files Confirm" + "When non-nil, prompts for confirmation before writing each modified buffer." + :value t) + +(defcommand "Save All Files" (p) + "Saves all modified buffers in their associated files. + If a buffer has no associated file it is ignored even if it is modified.." + "Saves each modified buffer that has a file." + (declare (ignore p)) + (let ((saved-count 0)) + (dolist (b *buffer-list*) + (let ((pn (buffer-pathname b)) + (name (buffer-name b))) + (when + (and (buffer-modified b) + pn + (or (not (value save-all-files-confirm)) + (prompt-for-y-or-n + :prompt (list + "Write ~:[buffer ~A as file ~S~;file ~*~S~], ~ + Y or N: " + (string= (pathname-to-buffer-name pn) name) + name (namestring pn)) + :default t))) + (write-buffer-file b pn) + (incf saved-count)))) + (if (zerop saved-count) + (message "No files were saved.") + (message "Saved ~S file~:P." saved-count)))) + +(defcommand "Save All Files and Exit" (p) + "Save all modified buffers in their associated files and exit; + a combination of \"Save All Files\" and \"Exit Hemlock\"." + "Do a save-all-files-command and then an exit-hemlock." + (declare (ignore p)) + (save-all-files-command ()) + (exit-hemlock)) + +(defcommand "Backup File" (p) + "Write the buffer to a file without changing the associated name." + "Write the buffer to a file without changing the associated name." + (declare (ignore p)) + (let ((file (prompt-for-file :prompt "Backup to File: " + :help + "Name of a file to backup the current buffer in." + :default (buffer-default-pathname (current-buffer)) + :must-exist nil))) + (write-file (buffer-region (current-buffer)) file) + (message "~A written." (namestring (truename file))))) + + + +;;;; Buffer hacking commands: + +(defvar *buffer-history* () + "A list of buffers, in order from most recently to least recently selected.") + +(defun previous-buffer () + "Returns some previously selected buffer that is not the current buffer. + Returns nil if no such buffer exists." + (let ((b (car *buffer-history*))) + (or (if (eq b (current-buffer)) (cadr *buffer-history*) b) + (find-if-not #'(lambda (x) + (or (eq x (current-buffer)) + (eq x *echo-area-buffer*))) + (the list *buffer-list*))))) + +;;; ADD-BUFFER-HISTORY-HOOK makes sure every buffer will be visited by +;;; "Circulate Buffers" even if it has never been before. +;;; +(defun add-buffer-history-hook (buffer) + (let ((ele (last *buffer-history*)) + (new-stuff (list buffer))) + (if ele + (setf (cdr ele) new-stuff) + (setf *buffer-history* new-stuff)))) +;;; +(add-hook make-buffer-hook 'add-buffer-history-hook) + +;;; DELETE-BUFFER-HISTORY-HOOK makes sure we never end up in a dead buffer. +;;; +(defun delete-buffer-history-hook (buffer) + (setq *buffer-history* (delq buffer *buffer-history*))) +;;; +(add-hook delete-buffer-hook 'delete-buffer-history-hook) + +(defun change-to-buffer (buffer) + "Switches to buffer in the current window maintaining *buffer-history*." + (setq *buffer-history* + (cons (current-buffer) (delq (current-buffer) *buffer-history*))) + (setf (current-buffer) buffer) + (setf (window-buffer (current-window)) buffer)) + +(defun delete-buffer-if-possible (buffer) + "Deletes a buffer if at all possible. If buffer is the only buffer, other + than the echo area, signals an error. Otherwise, find some recently current + buffer, and make all of buffer's windows display this recent buffer. If + buffer is current, set the current buffer to be this recently current + buffer." + (let ((new-buf (flet ((frob (b) + (or (eq b buffer) (eq b *echo-area-buffer*)))) + (or (find-if-not #'frob (the list *buffer-history*)) + (find-if-not #'frob (the list *buffer-list*)))))) + (unless new-buf + (error "Cannot delete only buffer ~S." buffer)) + (dolist (w (buffer-windows buffer)) + (setf (window-buffer w) new-buf)) + (when (eq buffer (current-buffer)) + (setf (current-buffer) new-buf))) + (delete-buffer buffer)) + + +(defvar *create-buffer-count* 0) + +(defcommand "Create Buffer" (p &optional buffer-name) + "Create a new buffer. If a buffer with the specified name already exists, + then go to it." + "Create or go to the buffer with the specifed name." + (declare (ignore p)) + (let ((name (or buffer-name + (prompt-for-buffer :prompt "Create Buffer: " + :default-string + (format nil "Buffer ~D" + (incf *create-buffer-count*)) + :must-exist nil)))) + (if (bufferp name) + (change-to-buffer name) + (change-to-buffer (or (getstring name *buffer-names*) + (make-buffer name)))))) + +(defcommand "Select Buffer" (p) + "Select a different buffer. + The buffer to go to is prompted for." + "Select a different buffer. + The buffer to go to is prompted for." + (declare (ignore p)) + (let ((buf (prompt-for-buffer :prompt "Select Buffer: " + :default (previous-buffer)))) + (when (eq buf *echo-area-buffer*) + (editor-error "Cannot select Echo Area buffer.")) + (change-to-buffer buf))) + + +(defvar *buffer-history-ptr* () + "The successively previous buffer to the current buffer.") + +(defcommand "Select Previous Buffer" (p) + "Select the buffer selected before this one. If called repeatedly + with an argument, select the successively previous buffer to the + current one leaving the buffer history as it is." + "Select the buffer selected before this one." + (if p + (circulate-buffers-command nil) + (let ((b (previous-buffer))) + (unless b (editor-error "No previous buffer.")) + (change-to-buffer b) + ;; + ;; If the pointer goes to nil, then "Circulate Buffers" will keep doing + ;; "Select Previous Buffer". + (setf *buffer-history-ptr* (cddr *buffer-history*)) + (setf (last-command-type) :previous-buffer)))) + +(defcommand "Circulate Buffers" (p) + "Advance through buffer history, selecting successively previous buffer." + "Advance through buffer history, selecting successively previous buffer." + (declare (ignore p)) + (if (and (eq (last-command-type) :previous-buffer) + *buffer-history-ptr*) ;Possibly nil if never CHANGE-TO-BUFFER. + (let ((b (pop *buffer-history-ptr*))) + (when (eq b (current-buffer)) + (setf b (pop *buffer-history-ptr*))) + (unless b + (setf *buffer-history-ptr* + (or (cdr *buffer-history*) *buffer-history*)) + (setf b (car *buffer-history*))) + (setf (current-buffer) b) + (setf (window-buffer (current-window)) b) + (setf (last-command-type) :previous-buffer)) + (select-previous-buffer-command nil))) + + +(defcommand "Buffer Not Modified" (p) + "Make the current buffer not modified." + "Make the current buffer not modified." + (declare (ignore p)) + (setf (buffer-modified (current-buffer)) nil) + (message "Buffer marked as unmodified.")) + +(defcommand "Check Buffer Modified" (p) + "Say whether the buffer is modified or not." + "Say whether the current buffer is modified or not." + (declare (ignore p)) + (clear-echo-area) + (message "Buffer ~S ~:[is not~;is~] modified." + (buffer-name (current-buffer)) (buffer-modified (current-buffer)))) + +(defcommand "Set Buffer Read-Only" (p) + "Toggles the read-only flag for the current buffer." + "Toggles the read-only flag for the current buffer." + (declare (ignore p)) + (let ((buffer (current-buffer))) + (message "Buffer ~S is now ~:[read-only~;writable~]." + (buffer-name buffer) + (setf (buffer-writable buffer) (not (buffer-writable buffer)))))) + +(defcommand "Kill Buffer" (p &optional buffer-name) + "Prompts for a buffer to delete. + If the buffer is modified, then let the user save the file before doing so. + When deleting the current buffer, prompts for a new buffer to select. If + a buffer other than the current one is deleted then any windows into it + are deleted." + "Delete buffer Buffer-Name, doing sensible things if the buffer is displayed + or current." + (declare (ignore p)) + (let ((buffer (if buffer-name + (getstring buffer-name *buffer-names*) + (prompt-for-buffer :prompt "Kill Buffer: " + :default (current-buffer))))) + (if (not buffer) + (editor-error "No buffer named ~S" buffer-name)) + (if (and (buffer-modified buffer) + (prompt-for-y-or-n :prompt "Save it first? ")) + (save-file-command () buffer)) + (if (eq buffer (current-buffer)) + (let ((new (prompt-for-buffer :prompt "New Buffer: " + :default (previous-buffer) + :help "Buffer to change to after the current one is killed."))) + (when (eq new buffer) + (editor-error "You must select a different buffer.")) + (dolist (w (buffer-windows buffer)) + (setf (window-buffer w) new)) + (setf (current-buffer) new)) + (dolist (w (buffer-windows buffer)) + (delete-window w))) + (delete-buffer buffer))) + +(defcommand "Rename Buffer" (p) + "Change the current buffer's name. + The name, which is prompted for, defaults to the name of the associated + file." + "Change the name of the current buffer." + (declare (ignore p)) + (let* ((buf (current-buffer)) + (pn (buffer-pathname buf)) + (name (if pn (pathname-to-buffer-name pn) (buffer-name buf))) + (new (prompt-for-string :prompt "New Name: " + :help "Give a new name for the current buffer" + :default name))) + (multiple-value-bind (entry foundp) (getstring new *buffer-names*) + (cond ((or (not foundp) (eq entry buf)) + (setf (buffer-name buf) new)) + (t (editor-error "Name ~S already in use." new)))))) + + +(defcommand "Insert Buffer" (p) + "Insert the contents of a buffer. + The name of the buffer to insert is prompted for." + "Prompt for a buffer to insert at the point." + (declare (ignore p)) + (let ((point (current-point)) + (region (buffer-region (prompt-for-buffer + :default (previous-buffer) + :help + "Type the name of a buffer to insert.")))) + ;; + ;; start and end will be deleted by undo stuff + (let ((save (region (copy-mark point :right-inserting) + (copy-mark point :left-inserting)))) + (push-buffer-mark (copy-mark point)) + (insert-region point region) + (make-region-undo :delete "Insert Buffer" save)))) + + + +;;;; File utility commands: + +(defcommand "Directory" (p) + "Do a directory into a pop-up window. If an argument is supplied, then + dot files are listed too (as with ls -a). Prompts for a pathname which + may contain wildcards in the name and type." + "Do a directory into a pop-up window." + (let* ((dpn (value pathname-defaults)) + (pn (prompt-for-file + :prompt "Directory: " + :help "Pathname to do directory on." + :default (make-pathname :device (pathname-device dpn) + :directory (pathname-directory dpn)) + :must-exist nil))) + (setf (value pathname-defaults) (merge-pathnames pn dpn)) + (with-pop-up-display (s) + (print-directory pn s :all p)))) + +(defcommand "Verbose Directory" (p) + "Do a directory into a pop-up window. If an argument is supplied, then + dot files are listed too (as with ls -a). Prompts for a pathname which + may contain wildcards in the name and type." + "Do a directory into a pop-up window." + (let* ((dpn (value pathname-defaults)) + (pn (prompt-for-file + :prompt "Verbose Directory: " + :help "Pathname to do directory on." + :default (make-pathname :device (pathname-device dpn) + :directory (pathname-directory dpn)) + :must-exist nil))) + (setf (value pathname-defaults) (merge-pathnames pn dpn)) + (with-pop-up-display (s) + (print-directory pn s :verbose t :all p)))) + + + +;;;; Change log stuff: + +(define-file-option "Log" (buffer value) + (defhvar "Log File Name" + "The name of the file for the change log for the file in this buffer." + :buffer buffer :value value)) + +(defhvar "Log Entry Template" + "The format string used to generate the template for a change-log entry. + Three arguments are given: the file, the date (create if available, now + otherwise) and the file author, or NIL if not available. The last \"@\" + is deleted and the point placed where it was." + :value "~A, ~A, Edit by ~:[???~;~:*~:(~A~)~].~% @~2%") + +(defmode "Log" + :major-p t + :setup-function + #'(lambda (buffer) + (setf (buffer-minor-mode buffer "Fill") t)) + :cleanup-function + #'(lambda (buffer) + (setf (buffer-minor-mode buffer "Fill") nil))) + +(defhvar "Fill Prefix" "The fill prefix in Log mode." + :value " " :mode "Log") + +(define-file-type-hook ("log") (buffer type) + (declare (ignore type)) + (setf (buffer-major-mode buffer) "Log")) + +(defun universal-time-to-string (ut) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time ut) + (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~2,'0D:~2,'0D" + day (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" + "Sep" "Oct" "Nov" "Dec") + (1- month)) + (rem year 100) + hour min sec))) + +(defvar *back-to-@-pattern* (new-search-pattern :character :backward #\@)) +(defcommand "Log Change" (p) + "Make an entry in the change-log file for this buffer. + Saves the file in the current buffer if it is modified, then finds the file + specified in the \"Log\" file option, adds the template for a change-log + entry at the beginning, then does a recursive edit, saving the log file on + exit." + "Find the change-log file as specified by \"Log File Name\" and edit it." + (declare (ignore p)) + (unless (hemlock-bound-p 'log-file-name) + (editor-error "No log file defined.")) + (let* ((buffer (current-buffer)) + (pathname (buffer-pathname buffer))) + (when (or (buffer-modified buffer) (null pathname)) + (save-file-command ())) + (unwind-protect + (progn + (find-file-command nil (merge-pathnames + (value log-file-name) + (buffer-default-pathname buffer))) + (let ((point (current-point))) + (buffer-start point) + (with-output-to-mark (s point :full) + (format s (value log-entry-template) + (namestring pathname) + (universal-time-to-string + (or (file-write-date pathname) + (get-universal-time))) + (file-author pathname))) + (when (find-pattern point *back-to-@-pattern*) + (delete-characters point 1))) + (do-recursive-edit) + (when (buffer-modified (current-buffer)) (save-file-command ()))) + (if (member buffer *buffer-list* :test #'eq) + (change-to-buffer buffer) + (editor-error "Old buffer has been deleted."))))) + + + +;;;; Window hacking commands: + +(defcommand "Next Window" (p) + "Change the current window to be the next window and the current buffer + to be it's buffer." + "Go to the next window. + If the next window is the bottom window then wrap around to the top window." + (declare (ignore p)) + (let* ((next (next-window (current-window))) + (buffer (window-buffer next))) + (setf (current-buffer) buffer (current-window) next))) + +(defcommand "Previous Window" (p) + "Change the current window to be the previous window and the current buffer + to be it's buffer." + "Go to the previous window. + If the Previous window is the top window then wrap around to the bottom." + (declare (ignore p)) + (let* ((previous (previous-window (current-window))) + (buffer (window-buffer previous))) + (setf (current-buffer) buffer (current-window) previous))) + +(defcommand "Split Window" (p) + "Make a new window by splitting the current window. + The new window is made the current window and displays starting at + the same place as the current window." + "Create a new window which displays starting at the same place + as the current window." + (declare (ignore p)) + (let ((new (make-window (window-display-start (current-window))))) + (unless new (editor-error "Could not make a new window.")) + (setf (current-window) new))) + +(defcommand "New Window" (p) + "Make a new window and go to it. + The window will display the same buffer as the current one." + "Create a new window which displays starting at the same place + as the current window." + (declare (ignore p)) + (let ((new (make-window (window-display-start (current-window)) + :ask-user t))) + (unless new (editor-error "Could not make a new window.")) + (setf (current-window) new))) + +(defcommand "Delete Window" (p) + "Delete the current window, going to the previous window." + "Delete the window we are in, going to the previous window." + (declare (ignore p)) + (let ((window (current-window))) + (previous-window-command ()) + (when (eq (current-window) window) + (editor-error "Cannot delete current window.")) + (delete-window window))) + +(defcommand "Line to Top of Window" (p) + "Move current line to top of window." + "Move current line to top of window." + (declare (ignore p)) + (with-mark ((mark (current-point))) + (move-mark (window-display-start (current-window)) (line-start mark)))) + +(defcommand "Delete Next Window" (p) + "Deletes the next window on display." + "Deletes then next window on display." + (declare (ignore p)) + (if (eq (next-window (current-window)) + (current-window)) + (editor-error "Cannot delete only window") + (delete-window (next-window (current-window))))) + +(defcommand "Line to Center of Window" (p) + "Moves current line to the center of the window." + "Moves current line to the center of the window." + (declare (ignore p)) + (center-window (current-window) (current-point))) diff --git a/hemlock/fill.lisp b/hemlock/fill.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3733b034d956b9478df716d5f5d44d4fe46cf2a1 --- /dev/null +++ b/hemlock/fill.lisp @@ -0,0 +1,738 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; +;;; This file contains the implementation of Auto Fill Mode. Also, +;;; paragraph and region filling stuff is here. +;;; + +(in-package "HEMLOCK") + + +;;; Fill Mode should be defined with some transparent bindings (linefeed and +;;; return) but with some that are not (space), so until this is possible, we +;;; kludge this effect by altering Auto Fill Linefeed and Auto Fill Return. +(defmode "Fill") + + + +;;;; -- Variables -- + +(defhvar "Fill Column" + "Used to determine at what column to force text to the next line." + :value 75) + +(defhvar "Fill Prefix" + "String to put before each line when filling." + :value ()) + +(defhvar "Auto Fill Space Indent" + "When non-nil, uses \"Indent New Comment Line\" to break lines instead of + \"New Line\". However, if there is a fill prefix, it is still preferred." + :value nil) + + + +;;;; -- New Attributes -- + +(defattribute "Paragraph Delimiter" + "is a character that delimits a paragraph by beginning a line." + '(mod 2) + 0) + + +;;; (setf (character-attribute :paragraph-delimiter #\@) 1) +;;; (setf (character-attribute :paragraph-delimiter #\\) 1) +;;; (setf (character-attribute :paragraph-delimiter #\/) 1) +;;; (setf (character-attribute :paragraph-delimiter #\-) 1) +;;; (setf (character-attribute :paragraph-delimiter #\') 1) +;;; (setf (character-attribute :paragraph-delimiter #\.) 1) +;;; These are useful for making certain text formatting command lines +;;; delimit paragraphs. Anyway, this is what EMACS documentation states, +;;; and #\' and #\. are always paragraph delimiters (don't ask me). + +(setf (character-attribute :paragraph-delimiter #\space) 1) +(setf (character-attribute :paragraph-delimiter #\linefeed) 1) +(setf (character-attribute :paragraph-delimiter #\formfeed) 1) +(setf (character-attribute :paragraph-delimiter #\tab) 1) +(setf (character-attribute :paragraph-delimiter #\newline) 1) + + + +(defattribute "Sentence Closing Char" + "is a delimiting character that may follow a sentence terminator + such as quotation marks and parentheses." + '(mod 2) + 0) + + +(setf (character-attribute :sentence-closing-char #\") 1) +(setf (character-attribute :sentence-closing-char #\') 1) +(setf (character-attribute :sentence-closing-char #\)) 1) +(setf (character-attribute :sentence-closing-char #\]) 1) +(setf (character-attribute :sentence-closing-char #\|) 1) +(setf (character-attribute :sentence-closing-char #\>) 1) + + + +;;;; -- Commands -- + +(defcommand "Auto Fill Mode" (p) + "Breaks lines between words at the right margin. + A positive argument turns Fill mode on, while zero or a negative + argument turns it off. With no arguments, it is toggled. When space + is typed, text that extends past the right margin is put on the next + line. The right column is controlled by Fill Column." + "Determine if in Fill mode or not and set the mode accordingly." + (setf (buffer-minor-mode (current-buffer) "Fill") + (if p + (plusp p) + (not (buffer-minor-mode (current-buffer) "Fill"))))) + + +;;; This command should not have a transparent binding since it sometimes does +;;; not insert a spaces, and transparency would propagate to "Self Insert". +(defcommand "Auto Fill Space" (p) + "Insert space and a CRLF if text extends past margin. + If arg is 0, then may break line but will not insert the space. + If arg is positive, then inserts that many spaces without filling." + "Insert space and CRLF if text extends past margin. + If arg is 0, then may break line but will not insert the space. + If arg is positive, then inserts that many spaces without filling." + (let ((point (current-point))) + (check-fill-prefix (value fill-prefix) (value fill-column) point) + (cond ((and p (plusp p)) + (dotimes (x p) (insert-character point #\space))) + ((and p (zerop p)) (%auto-fill-space point nil)) + (t (%auto-fill-space point t))))) + + +(defcommand "Auto Fill Linefeed" (p) + "Does an immediate CRLF inserting Fill Prefix if it exists." + "Does an immediate CRLF inserting Fill Prefix if it exists." + (declare (ignore p)) + (let ((point (current-point))) + (check-fill-prefix (value fill-prefix) (value fill-column) point) + (%auto-fill-space point nil) + ;; The remainder of this function should go away when + ;; transparent key bindings are per binding instead of + ;; per mode. + (multiple-value-bind (command t-bindings) + (get-command #\linefeed :current) + (declare (ignore command)) ;command is this one, so don't invoke it + (dolist (c t-bindings) (funcall *invoke-hook* c p))) + (indent-new-line-command nil))) + + + +(defcommand "Auto Fill Return" (p) + "Does an Auto Fill Space with a prefix argument of 0 + followed by a newline." + "Does an Auto Fill Space with a prefix argument of 0 + followed by a newline." + (declare (ignore p)) + (let ((point (current-point))) + (check-fill-prefix (value fill-prefix) (value fill-column) point) + (%auto-fill-space point nil) + ;; The remainder of this function should go away when + ;; transparent key bindings are per binding instead of + ;; per mode. + (multiple-value-bind (command t-bindings) + (get-command #\return :current) + (declare (ignore command)) ;command is this one, so don't invoke it + (dolist (c t-bindings) (funcall *invoke-hook* c p))) + (new-line-command nil))) + + + +(defcommand "Fill Paragraph" (p) + "Fill this or next paragraph. + Point stays fixed, but text may move past it due to filling. + A paragraph is delimited by a blank line, a line beginning with a + special character (@,\,-,',and .), or it is begun with a line with at + least one whitespace character starting it. Prefixes are ignored or + skipped over before determining if a line starts or delimits a + paragraph." + "Fill this or next paragraph. + Point stays fixed, but text may move past it due to filling." + (let* ((prefix (value fill-prefix)) + (prefix-len (length prefix)) + (column (if p (abs p) (value fill-column))) + (point (current-point))) + (with-mark ((m point)) + (let ((paragraphp (paragraph-offset m 1))) + (unless (or paragraphp + (and (last-line-p m) + (end-line-p m) + (not (blank-line-p (mark-line m))))) + (editor-error)) + ;; + ;; start and end get deleted by the undo cleanup function + (let ((start (copy-mark m :right-inserting)) + (end (copy-mark m :left-inserting))) + (%fill-paragraph-start start prefix prefix-len) + (let* ((region (region start end)) + (undo-region (copy-region region))) + (fill-region region prefix column) + (make-region-undo :twiddle "Fill Paragraph" region undo-region))))))) + + +(defcommand "Fill Region" (p) + "Fill text from point to mark." + "Fill text from point to mark." + (declare (ignore p)) + (let* ((region (current-region)) + (prefix (value fill-prefix)) + (column (if p (abs p) (value fill-column)))) + (check-fill-prefix prefix column (current-point)) + (check-region-query-size region) + (fill-region-by-paragraphs region prefix column))) + + + +(defcommand "Set Fill Column" (p) + "Set Fill Column to current column or argument. + If argument is provided use its absolute value." + "Set Fill Column to current column or argument. + If argument is provided use its absolute value." + (let ((new-column (or (and p (abs p)) + (mark-column (current-point))))) + (defhvar "Fill Column" "This buffer's fill column" + :value new-column :buffer (current-buffer)) + (message "Fill Column = ~D" new-column))) + + +(defcommand "Set Fill Prefix" (p) + "Define Fill Prefix from the current line. + All of the current line up to point is the prefix. This may be + turned off by placing point at the beginning of a line when setting." + "Define Fill Prefix from the current line. + All of the current line up to point is the prefix. This may be + turned off by placing point at the beginning of a line when setting." + (declare (ignore p)) + (let ((point (current-point))) + (with-mark ((mark point)) + (line-start mark) + (let ((val (if (mark/= mark point) (region-to-string (region mark point))))) + (defhvar "Fill Prefix" "This buffer's fill prefix" + :value val :buffer (current-buffer)) + (message "Fill Prefix now ~:[empty~;~:*~S~]" val))))) + + +;;;; -- Auto Filling -- + +;;; %AUTO-FILL-SPACE takes a point and an argument indicating +;;; whether it should insert a space or not. If point is past Fill +;;; Column then text is filled. Usually the else clause of the if +;;; will be executed. If the then clause is executed, then the first +;;; branch of the COND will usually be executed. The first branch +;;; handles the case of the end of a word extending past Fill Column +;;; while the second handles whitespace preceded by non-whitespace +;;; extending past the Fill Column. The last branch is for those who +;;; like to whitespace out a blank line. + +(defun %auto-fill-space (point insertp) + "Insert space, but CRLF if text extends past margin. + If arg is 0, then may break line but will not insert the space. + If arg is positive, then inserts that many spaces without filling." + (if (> (mark-column point) (value fill-column)) + (with-mark ((mark1 point :left-inserting)) + (let ((not-all-blank (reverse-find-attribute mark1 :whitespace #'zerop)) + (prefix (value fill-prefix)) + (column (value fill-column))) + (cond ((and not-all-blank (mark= point mark1)) + (%auto-fill-word-past-column point mark1 insertp prefix column)) + ((and not-all-blank (same-line-p mark1 point)) + (delete-region (region mark1 point)) + (if (> (mark-column point) column) + (%auto-fill-word-past-column point mark1 insertp prefix column) + (%filling-set-next-line point nil prefix))) + (t + (line-start mark1 (mark-line point)) + (delete-region (region mark1 point)) + (%filling-set-next-line point nil prefix))))) + (if insertp (insert-character point #\space)))) + + + +;;; %AUTO-FILL-WORD-PAST-COLUMN takes a point, a second mark that is +;;; mark= at the end of some word, and an indicator of whether a space +;;; should be inserted or not. First, point is moved before the previous +;;; "word." If the word is effectively the only word on the line, it +;;; should not be moved down to the next line as it will leave a blank +;;; line. The third branch handles when the typing began in the middle of +;;; some line (that is, right in front of some word). Note that the else +;;; clause is the usual case. + +(defun %auto-fill-word-past-column (point mark1 insertp prefix column) + (let ((point-moved-p (reverse-find-attribute point :whitespace))) + (with-mark ((mark2 point :left-inserting)) + (cond ((or (not point-moved-p) + (%auto-fill-blank-before-p point prefix)) + (move-mark point mark1) + (%filling-set-next-line point nil prefix)) + ((%auto-fill-line-as-region-p point mark2 column) + (if (and insertp + (not (or (end-line-p mark1) + (whitespace-attribute-p (next-character mark1))))) + (insert-character mark1 #\space)) + (auto-fill-line-as-region point (move-mark mark2 point) prefix column) + (move-mark point mark1) + (if (and insertp (end-line-p point)) + (insert-character point #\space))) + ((not (or (end-line-p mark1) + (whitespace-attribute-p (next-character mark1)))) + (insert-character mark1 #\space) + (%filling-set-next-line point nil prefix) + (mark-after point) + (%auto-fill-clean-previous-line mark1 mark2)) + (t + (%filling-set-next-line point insertp prefix) + (%auto-fill-clean-previous-line mark1 mark2)))))) + + + +;;; AUTO-FILL-LINE-AS-REGION basically grabs a line as a region and fills +;;; it. However, it knows about comments and makes auto filling a comment +;;; line as a region look the same as a typical "back up a word and break +;;; the line." When there is a comment, then region starts where the +;;; comment starts instead of the beginning of the line, but the presence +;;; of a prefix overrides all this. + +(defun auto-fill-line-as-region (point mark prefix column) + (let* ((start (value comment-start)) + (begin (value comment-begin)) + (end (value comment-end))) + (line-start mark) + (cond ((and (not prefix) start (to-line-comment mark start)) + (fill-region (region mark (line-end point)) + (gen-comment-prefix mark start begin) + column) + (when end + (line-start point) + (do () + ((mark>= mark point)) + (if (not (to-comment-end mark end)) (insert-string mark end)) + (line-offset mark 1 0)))) + (t (fill-region (region mark (line-end point)) prefix column))))) + + + +(defun %auto-fill-blank-before-p (point prefix) + "is true if whitespace only precedes point except for the prefix." + (or (blank-before-p point) + (with-mark ((temp point)) + (reverse-find-attribute temp :whitespace #'zerop) + (<= (mark-column temp) (length prefix))))) + + + +;;; %AUTO-FILL-LINE-AS-REGION-P determines if the line point and mark2 +;;; sit on is so long that it might as well be filled as if it were a +;;; region. Mark2 is mark= to point at the beginning of the last word on +;;; the line and is then moved over the whitespace before point. If the +;;; word end prior the last word on the line is on the same line and not +;;; before column, then fill the line as a region. + +(defun %auto-fill-line-as-region-p (point mark2 column) + (reverse-find-attribute mark2 :whitespace #'zerop) + (and (same-line-p mark2 point) + (> (mark-column mark2) column))) + + + +(defun %auto-fill-clean-previous-line (mark1 mark2) + (when (line-offset mark1 -1) + (line-end mark1) + (move-mark mark2 mark1) + (unless (and (reverse-find-attribute mark1 :whitespace #'zerop) + (same-line-p mark1 mark2)) + (line-start mark1 (mark-line mark2))) + (delete-region (region mark1 mark2)))) + + + +;;; %FILLING-SET-NEXT-LINE gets a new blank line and sets it up with the +;;; prefix and places the point correctly. The argument point must alias +;;; (current-point). + +(defun %filling-set-next-line (point insertp prefix) + (cond ((and (value auto-fill-space-indent) (not prefix)) + (indent-new-comment-line-command nil)) + (t (new-line-command nil) + (if prefix (insert-string point prefix)))) + (if (not (find-attribute point :whitespace)) (line-end point)) + (if insertp (insert-character point #\space))) + + + +;;;; -- Paragraph Filling -- + + +;;; %FILL-PARAGRAPH-START takes a mark that has just been moved +;;; forward over some paragraph. After moving to the beginning of it, we +;;; place the mark appropriately for filling the paragraph as a region. + +(defun %fill-paragraph-start (mark prefix prefix-len) + (paragraph-offset mark -1) + (skip-prefix-if-here mark prefix prefix-len) + (if (text-blank-line-p mark) + (line-offset mark 1 0) + (line-start mark))) + + + +;;;; -- Region Filling -- + + +;;; FILL-REGION-BY-PARAGRAPHS finds paragraphs and uses region filling +;;; primitives to fill them. Tmark2 is only used for the first paragraph; we +;;; need a mark other than start in case start is in the middle of a paragraph +;;; instead of between two. +;;; +(defun fill-region-by-paragraphs (region &optional + (prefix (value fill-prefix)) + (column (value fill-column))) + "Finds paragraphs in region and fills them as distinct regions using + FILL-REGION." + (with-mark ((start (region-start region) :left-inserting)) + (with-mark ((tmark1 start :left-inserting) + (tmark2 start :left-inserting)) ;only used for first para. + (let ((region (region (copy-mark (region-start region)) ;deleted by undo. + (copy-mark (region-end region)))) + (undo-region (copy-region region)) + (end (region-end region)) + (prefix-len (length prefix)) + (paragraphp (paragraph-offset tmark1 1))) + (when paragraphp + (%fill-paragraph-start (move-mark tmark2 tmark1) prefix prefix-len) + (if (mark>= tmark2 start) (move-mark start tmark2)) + (cond ((mark>= tmark1 end) + (fill-region-aux start end prefix prefix-len column)) + (t + (fill-region-aux start tmark1 prefix prefix-len column) + (do ((paragraphp (mark-paragraph start tmark1) + (mark-paragraph start tmark1))) + ((not paragraphp)) + (if (mark> start end) + (return) + (cond ((mark>= tmark1 end) + (fill-region-aux start end prefix + prefix-len column) + (return)) + (t (fill-region-aux start tmark1 + prefix prefix-len column)))))))) + (make-region-undo :twiddle "Fill Region" region undo-region))))) + +(defun fill-region (region &optional + (prefix (value fill-prefix)) + (column (value fill-column))) + "Fills a region using the given prefix and column." + (let ((prefix (if (and prefix (string= prefix "")) () prefix))) + (with-mark ((start (region-start region) :left-inserting)) + (check-fill-prefix prefix column start) + (fill-region-aux start (region-end region) + prefix (length prefix) column)))) + + + +;;; FILL-REGION-AUX grinds over a region between fill-mark and +;;; end-mark deleting blank lines and filling lines. For each line, the +;;; extra whitespace between words is collapsed to one space, and at the +;;; end and beginning of the line it is deleted. We do not return after +;;; realizing that fill-mark is after end-mark if the line needs to be +;;; broken; it may be the case that there are several filled line lengths +;;; of material before end-mark on the current line. + +(defun fill-region-aux (fill-mark end-mark prefix prefix-len column) + (if (and (start-line-p fill-mark) prefix) + (fill-region-prefix-line fill-mark prefix prefix-len)) + (with-mark ((mark1 fill-mark :left-inserting) + (cmark fill-mark :left-inserting)) + (do ((collapse-p t)) + (nil) + (line-end fill-mark) + (line-start (move-mark mark1 fill-mark)) + (skip-prefix-if-here mark1 prefix prefix-len) + (cond ((mark>= fill-mark end-mark) + (if (mark= fill-mark end-mark) + (fill-region-clear-eol fill-mark)) + (cond ((> (mark-column end-mark) column) + (when collapse-p + (fill-region-collapse-whitespace cmark end-mark) + (setf collapse-p nil)) + (fill-region-break-line fill-mark prefix + prefix-len end-mark column)) + (t (return)))) + ((blank-after-p mark1) + (fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len) + (cond ((mark< fill-mark end-mark) + (if prefix + (fill-region-prefix-line fill-mark prefix prefix-len)) + (fill-region-clear-bol fill-mark) + (move-mark cmark fill-mark)) + (t (return))) + (setf collapse-p t)) + (t (fill-region-clear-eol fill-mark) + (if collapse-p (fill-region-collapse-whitespace cmark fill-mark)) + (cond ((> (mark-column fill-mark) column) + (fill-region-break-line fill-mark prefix + prefix-len end-mark column) + (setf collapse-p nil)) + (t (fill-region-get-next-line fill-mark column + prefix prefix-len end-mark) + (move-mark cmark fill-mark) + (setf collapse-p t)))))) + (move-mark fill-mark end-mark))) + + + +;;; FILL-REGION-BREAK-LINE breaks lines as close to the low side +;;; column as possible. The first branch handles a word lying across +;;; column while the second takes care of whitespace passing column. If +;;; FILL-REGION-WORD-PAST-COLUMN encountered a single word stretching over +;;; column, it would leave an extra opened line that needs to be cleaned up +;;; or filled up. + +(defun fill-region-break-line (fill-mark prefix prefix-length + end-mark column) + (with-mark ((mark1 fill-mark :left-inserting)) + (move-to-column mark1 column) + (cond ((not (whitespace-attribute-p (next-character mark1))) + (if (not (find-attribute mark1 :whitespace)) + (line-end mark1)) + (move-mark fill-mark mark1) + (if (eq (fill-region-word-past-column fill-mark mark1 prefix) + :handled-oversized-word) + (if (mark>= fill-mark end-mark) + (delete-characters (line-start fill-mark) + prefix-length) + (delete-characters fill-mark 1)))) + (t (move-mark fill-mark mark1) + (unless (and (reverse-find-attribute mark1 :whitespace #'zerop) + (same-line-p mark1 fill-mark)) + (line-start mark1 (mark-line fill-mark))) + ;; forward find must move mark because of cond branch we are in. + (find-attribute fill-mark :whitespace #'zerop) + (unless (same-line-p mark1 fill-mark) + (line-end fill-mark (mark-line mark1))) + (delete-region (region mark1 fill-mark)) + (insert-character fill-mark #\newline) + (if prefix (insert-string fill-mark prefix)))))) + + + +;;; FILL-REGION-WORD-PAST-COLUMN takes a point and a second mark that +;;; is mark= at the end of some word. First, point is moved before the +;;; previous "word." If the word is effectively the only word on the line, +;;; it should not be moved down to the next line as it will leave a blank +;;; line. + +(defun fill-region-word-past-column (point mark1 prefix) + (with-mark ((mark2 (copy-mark point :left-inserting))) + (let ((point-moved-p (reverse-find-attribute point :whitespace)) + (hack-for-fill-region :handled-normal-case)) + (cond ((or (not point-moved-p) + (%auto-fill-blank-before-p point prefix)) + (setf hack-for-fill-region :handled-oversized-word) + (move-mark point mark1) + (fill-region-set-next-line point prefix)) + (t (fill-region-set-next-line point prefix) + (%auto-fill-clean-previous-line mark1 mark2))) + hack-for-fill-region))) + +(defun fill-region-set-next-line (point prefix) + (insert-character point #\newline) + (if prefix (insert-string point prefix)) + (if (not (find-attribute point :whitespace)) (line-end point))) + + + +;;; FILL-REGION-GET-NEXT-LINE gets another line when the current one +;;; is short of the fill column. It cleans extraneous whitespace from the +;;; beginning of the next line to fill. To save typical redisplay the +;;; length of the first word is added to the ending column of the current +;;; line to see if it extends past the fill column; if it does, then the +;;; fill-mark is left on the new line instead of merging the new line with +;;; the current one. The fill-mark is left after a prefix (if there is one) +;;; on a new line, before the first word brought up to the current line, or +;;; after the end mark. + +(defun fill-region-get-next-line (fill-mark column prefix prefix-len end-mark) + (let ((prev-end-pos (mark-column fill-mark)) + (two-spaces-p (fill-region-insert-two-spaces-p fill-mark))) + (with-mark ((tmark fill-mark :left-inserting)) + (fill-region-find-next-line fill-mark prefix prefix-len end-mark) + (move-mark tmark fill-mark) + (cond ((mark< fill-mark end-mark) + (skip-prefix-if-here tmark prefix prefix-len) + (fill-region-clear-bol tmark) + (let ((beginning-pos (mark-column tmark))) + (find-attribute tmark :whitespace) + (cond ((> (+ prev-end-pos (if two-spaces-p 2 1) + (- (mark-column tmark) beginning-pos)) + column) + (if prefix + (fill-region-prefix-line fill-mark prefix prefix-len))) + (t + (if (and prefix + (%line-has-prefix-p fill-mark prefix prefix-len)) + (delete-characters fill-mark prefix-len)) + (delete-characters fill-mark -1) + (insert-character fill-mark #\space) + (if two-spaces-p (insert-character fill-mark #\space)))))) + (t + (mark-after fill-mark)))))) + + + +;;; FILL-REGION-FIND-NEXT-LINE finds the next non-blank line, modulo +;;; fill prefixes, and deletes the intervening lines. Fill-mark is left at +;;; the beginning of the next line. + +(defun fill-region-find-next-line (fill-mark prefix prefix-len end-mark) + (line-offset fill-mark 1 0) + (when (mark< fill-mark end-mark) + (skip-prefix-if-here fill-mark prefix prefix-len) + (if (blank-after-p fill-mark) + (fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len) + (line-start fill-mark)))) + + + +;;; FILL-REGION-DELETE-BLANK-LINES deletes the blank line mark is on +;;; and all successive blank lines. Mark is left at the beginning of the +;;; first non-blank line by virtue of its placement and region deletions. + +(defun fill-region-delete-blank-lines (mark end-mark prefix prefix-len) + (line-start mark) + (with-mark ((tmark mark :left-inserting)) + (do ((linep (line-offset tmark 1 0) (line-offset tmark 1 0))) + ((not linep) + (move-mark tmark end-mark) + (delete-region (region mark tmark))) + (skip-prefix-if-here tmark prefix prefix-len) + (when (mark>= tmark end-mark) + (move-mark tmark end-mark) + (delete-region (region mark tmark)) + (return)) + (unless (blank-after-p tmark) + (line-start tmark) + (delete-region (region mark tmark)) + (return))))) + + + +;;; FILL-REGION-CLEAR-BOL clears the initial whitespace on a line +;;; known to be non-blank. Note that the fill prefix is not considered, so +;;; the mark must have been moved over it already if there is one. + +(defun fill-region-clear-bol (mark) + (with-mark ((tmark mark :left-inserting)) + (find-attribute tmark :whitespace #'zerop) + (unless (mark= mark tmark) + (delete-region (region mark tmark))))) + + + +;;; FILL-REGION-COLLAPSE-WHITESPACE deletes extra whitespace between +;;; blocks of non-whitespace characters from mark1 to mark2. Tabs are +;;; converted into a single space. Mark2 must be on the same line as mark1 +;;; since there is no concern of newlines, prefixes on a new line, blank +;;; lines between blocks of non-whitespace characters, etc. + +(defun fill-region-collapse-whitespace (mark1 mark2) + (with-mark ((tmark mark1 :left-inserting)) + ;; skip whitespace at beginning of line or single space between words + (find-attribute mark1 :whitespace #'zerop) + (unless (mark>= mark1 mark2) + (do () + (nil) + (if (not (find-attribute mark1 :whitespace)) ;not end of buffer + (return)) + (if (mark>= mark1 mark2) (return)) + (if (char/= (next-character mark1) #\space) + ;; since only on one line, must be tab or space + (setf (next-character mark1) #\space)) + (move-mark tmark mark1) + (if (mark= (mark-after mark1) mark2) (return)) + (let ((char (next-character mark1))) + (when (and (fill-region-insert-two-spaces-p tmark) + (char= char #\space)) + ;; if at the end of a sentence, don't blow away the second space + (if (mark= (mark-after mark1) mark2) + (return) + (setf char (next-character mark1)))) + (when (whitespace-attribute-p char) ;more whitespace than necessary + (find-attribute (move-mark tmark mark1) :whitespace #'zerop) + (if (mark>= tmark mark2) (move-mark tmark mark2)) + (delete-region (region mark1 tmark)))))))) + + + +;;; FILL-REGION-CLEAR-EOL must check the result of +;;; REVERSE-FIND-ATTRIBUTE because if fill-mark did not move, then we are +;;; only whitespace away from the beginning of the buffer. + +(defun fill-region-clear-eol (fill-mark) + (with-mark ((mark1 fill-mark :left-inserting)) + (unless (and (reverse-find-attribute mark1 :whitespace #'zerop) + (same-line-p mark1 fill-mark)) + (line-start mark1 (mark-line fill-mark))) + (delete-region (region mark1 fill-mark)))) + + + +(defun fill-region-prefix-line (fill-mark prefix prefix-length) + (if (%line-has-prefix-p fill-mark prefix prefix-length) + (character-offset fill-mark prefix-length) + (insert-string fill-mark prefix))) + + + +(defun %line-has-prefix-p (mark prefix prefix-length) + (declare (simple-string prefix)) + (if (>= (line-length (mark-line mark)) prefix-length) + (string= prefix (the simple-string (line-string (mark-line mark))) + :end2 prefix-length))) + + + +;;; FILL-REGION-INSERT-TWO-SPACES-P returns true if a sentence +;;; terminator is followed by any number of "closing characters" such as +;;; ",',),etc. If there is a sentence terminator at the end of the current +;;; line, it must be assumed to be the end of a sentence as opposed to an +;;; abbreviation. Why? Because EMACS does, and besides, what would Lisp +;;; code be without heuristics. + +(defun fill-region-insert-two-spaces-p (mark) + (do ((n 0 (1+ n))) + ((not (sentence-closing-char-attribute-p (previous-character mark))) + (cond ((sentence-terminator-attribute-p (previous-character mark)) + (character-offset mark n)) + (t (character-offset mark n) nil))) + (mark-before mark))) + + + +(defun check-fill-prefix (prefix column mark) + (when prefix + (insert-character mark #\newline) + (insert-character mark #\newline) + (mark-before mark) + (insert-string mark prefix) + (let ((pos (mark-column mark))) + (declare (simple-string prefix)) + (mark-after mark) + (delete-characters mark (- (+ (length prefix) 2))) + (if (>= pos column) + (editor-error + "The fill prefix length is longer than the fill column."))))) diff --git a/hemlock/group.lisp b/hemlock/group.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e962d5259ec31eb03408c4a8b0f39fb0f447b118 --- /dev/null +++ b/hemlock/group.lisp @@ -0,0 +1,234 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. If +;;; you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; File group stuff for Hemlock. +;;; Written by Skef Wholey and Rob MacLachlan. +;;; +;;; The "Compile Group" and "List Compile Group" commands in lispeval +;;; also know about groups. +;;; +;;; This file provides Hemlock commands for manipulating groups of files +;;; that make up a larger system. A file group is a set of files whose +;;; names are listed in some other file. At any given time one group of +;;; files is the Active group. The Select Group command makes a group the +;;; Active group, prompting for the name of a definition file if the group +;;; has not been selected before. Once a group has been selected once, the +;;; name of the definition file associated with that group is retained. If +;;; one wishes to change the name of the definition file after a group has +;;; been selected, one should call Select Group with a prefix argument. + +(in-package 'hemlock) + +(defvar *file-groups* (make-string-table) + "A string table of file groups.") + +(defvar *active-file-group* () + "The list of files in the currently active group.") + +(defvar *active-file-group-name* () + "The name of the currently active group.") + + + +;;;; Selecting the active group. + +(defcommand "Select Group" (p) + "Makes a group the active group. With a prefix argument, changes the + definition file associated with the group." + "Makes a group the active group." + (let* ((group-name + (prompt-for-keyword + (list *file-groups*) + :must-exist nil + :prompt "Select Group: " + :help + "Type the name of the file group you wish to become the active group.")) + (old (getstring group-name *file-groups*)) + (pathname + (if (and old (not p)) + old + (prompt-for-file :must-exist t + :prompt "From File: " + :default (merge-pathnames + (make-pathname + :name group-name + :type "upd") + (value pathname-defaults)))))) + (setq *active-file-group-name* group-name) + (setq *active-file-group* (nreverse (read-file-group pathname nil))) + (setf (getstring group-name *file-groups*) pathname))) + + +;;; READ-FILE-GROUP reads an Update format file and returns a list of pathnames +;;; of the files named in that file. This guy knows about @@ indirection and +;;; ignores empty lines and lines that begin with @ but not @@. A simpler +;;; scheme could be used for non-Spice implementations, but all this hair is +;;; probably useful, so Update format may as well be a standard for this sort +;;; of thing. +;;; +(defun read-file-group (pathname tail) + (with-open-file (file pathname) + (do* ((name (read-line file nil nil) (read-line file nil nil)) + (length (if name (length name)) (if name (length name)))) + ((null name) tail) + (declare (simple-string name)) + (cond ((zerop length)) + ((char= (char name 0) #\@) + (when (and (> length 1) (char= (char name 1) #\@)) + (setq tail (read-file-group + (merge-pathnames (subseq name 2) + pathname) + tail)))) + (t + (push (merge-pathnames (pathname name) pathname) tail)))))) + + + +;;;; DO-ACTIVE-GROUP. + +(defhvar "Group Find File" + "If true, group commands use \"Find File\" to read files, otherwise + non-resident files are read into the \"Group Search\" buffer." + :value nil) + +(defhvar "Group Save File Confirm" + "If true, then the group commands will ask for confirmation before saving + a modified file." :value t) + +(defmacro do-active-group (&rest forms) + "This iterates over the active file group executing forms once for each + file. When forms are executed, the file will be in the current buffer, + and the point will be at the start of the file." + (let ((n-buf (gensym)) + (n-start-buf (gensym)) + (n-save (gensym))) + `(progn + (unless *active-file-group* + (editor-error "There is no active file group.")) + + (let ((,n-start-buf (current-buffer)) + (,n-buf nil)) + (unwind-protect + (dolist (file *active-file-group*) + (catch 'file-not-found + (setq ,n-buf (group-read-file file ,n-buf)) + (with-mark ((,n-save (current-point) :right-inserting)) + (unwind-protect + (progn + (buffer-start (current-point)) + ,@forms) + (move-mark (current-point) ,n-save))) + (group-save-file))) + (if (member ,n-start-buf *buffer-list*) + (setf (current-buffer) ,n-start-buf + (window-buffer (current-window)) ,n-start-buf) + (editor-error "Original buffer deleted!"))))))) + +;;; GROUP-READ-FILE reads in files for the group commands via DO-ACTIVE-GROUP. +;;; We use FIND-FILE-BUFFER, which creates a new buffer when the file hasn't +;;; already been read, to get files in, and then we delete the buffer if it is +;;; newly created and "Group Find File" is false. This lets FIND-FILE-BUFFER +;;; do all the work. We don't actually use the "Find File" command, so the +;;; buffer history isn't affected. +;;; +;;; Search-Buffer is any temporary search buffer left over from the last file +;;; that we want deleted. We don't do the deletion if the buffer is modified. +;;; +(defun group-read-file (name search-buffer) + (unless (probe-file name) + (message "File ~A not found." name) + (throw 'file-not-found nil)) + (multiple-value-bind (buffer created-p) + (find-file-buffer name) + (setf (current-buffer) buffer) + (setf (window-buffer (current-window)) buffer) + + (when (and search-buffer (not (buffer-modified search-buffer))) + (dolist (w (buffer-windows search-buffer)) + (setf (window-buffer w) (current-buffer))) + (delete-buffer search-buffer)) + + (if (and created-p (not (value group-find-file))) + (current-buffer) nil))) + +;;; GROUP-SAVE-FILE is used by DO-ACTIVE-GROUP. +;;; +(defun group-save-file () + (let* ((buffer (current-buffer)) + (pn (buffer-pathname buffer)) + (name (namestring pn))) + (when (and (buffer-modified buffer) + (or (not (value group-save-file-confirm)) + (prompt-for-y-or-n + :prompt (list "Save changes in ~A? " name) + :default t))) + (save-file-command ())))) + + + +;;;; Searching and Replacing commands. + +(defcommand "Group Search" (p) + "Searches the active group for a specified string, which is prompted for." + "Searches the active group for a specified string." + (declare (ignore p)) + (let ((string (prompt-for-string :prompt "Group Search: " + :help "String to search for in active file group" + :default *last-search-string*))) + (get-search-pattern string :forward) + (do-active-group + (do ((won (find-pattern (current-point) *last-search-pattern*) + (find-pattern (current-point) *last-search-pattern*))) + ((not won)) + (character-offset (current-point) won) + (command-case + (:prompt "Group Search: " + :help "Type a character indicating the action to perform." + :change-window nil) + (:no "Search for the next occurrence.") + (:do-all "Go on to the next file in the group." + (return nil)) + ((:exit :yes) "Exit the search." + (return-from group-search-command)) + (:recursive-edit "Enter a recursive edit." + (do-recursive-edit) + (get-search-pattern string :forward))))) + (message "All files in group ~S searched." *active-file-group-name*))) + +(defcommand "Group Replace" (p) + "Replaces one string with another in the active file group." + "Replaces one string with another in the active file group." + (declare (ignore p)) + (let* ((target (prompt-for-string :prompt "Group Replace: " + :help "Target string" + :default *last-search-string*)) + (replacement (prompt-for-string :prompt "With: " + :help "Replacement string"))) + (do-active-group + (query-replace-function nil target replacement + "Group Replace on previous file" t)) + (message "Replacement done in all files in group ~S." + *active-file-group-name*))) + +(defcommand "Group Query Replace" (p) + "Query Replace for the active file group." + "Query Replace for the active file group." + (declare (ignore p)) + (let ((target (prompt-for-string :prompt "Group Query Replace: " + :help "Target string" + :default *last-search-string*))) + (let ((replacement (prompt-for-string :prompt "With: " + :help "Replacement string"))) + (do-active-group + (unless (query-replace-function + nil target replacement "Group Query Replace on previous file") + (return nil))) + (message "Replacement done in all files in group ~S." + *active-file-group-name*)))) diff --git a/hemlock/htext2.lisp b/hemlock/htext2.lisp new file mode 100644 index 0000000000000000000000000000000000000000..edfd0a8380dda27685e57998d50a12118d85462e --- /dev/null +++ b/hemlock/htext2.lisp @@ -0,0 +1,498 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; More Hemlock Text-Manipulation functions. +;;; Written by Skef Wholey. +;;; +;;; The code in this file implements the non-insert/delete functions in the +;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document. +;;; + +(in-package "HEMLOCK-INTERNALS") + +(export '(region-to-string string-to-region line-to-region + previous-character next-character count-lines + count-characters line-start line-end buffer-start + buffer-end move-mark mark-before mark-after + character-offset line-offset region-bounds + set-region-bounds *print-region*)) + + + +(defun region-to-string (region) + "Returns a string containing the characters in the given Region." + (close-line) + (let* ((dst-length (count-characters region)) + (string (make-string dst-length)) + (start-mark (region-start region)) + (end-mark (region-end region)) + (start-line (mark-line start-mark)) + (end-line (mark-line end-mark)) + (start-charpos (mark-charpos start-mark))) + (declare (simple-string string)) + (if (eq start-line end-line) + (%sp-byte-blt (line-chars start-line) start-charpos string 0 + dst-length) + (let ((index ())) + (let* ((line-chars (line-chars start-line)) + (dst-end (- (length line-chars) start-charpos))) + (declare (simple-string line-chars)) + (%sp-byte-blt line-chars start-charpos string 0 dst-end) + (setf (char string dst-end) #\newline) + (setq index (1+ dst-end))) + (do* ((line (line-next start-line) (line-next line)) + (chars (line-chars line) (line-chars line))) + ((eq line end-line) + (%sp-byte-blt (line-chars line) 0 string index dst-length)) + (declare (simple-string chars)) + (%sp-byte-blt (line-chars line) 0 string index + (incf index (length chars))) + (setf (char string index) #\newline) + (setq index (1+ index))))) + string)) + +(defun string-to-region (string) + "Returns a region containing the characters in the given String." + (let* ((string (if (simple-string-p string) + string (coerce string 'simple-string))) + (end (length string))) + (declare (simple-string string)) + (do* ((index 0) + (buffer (incf *disembodied-buffer-counter*)) + (previous-line) + (line (make-line :%buffer buffer)) + (first-line line)) + (()) + (let ((right-index (%sp-find-character string index end #\newline))) + (cond (right-index + (let* ((length (- right-index index)) + (chars (make-string length))) + (%sp-byte-blt string index chars 0 length) + (setf (line-chars line) chars)) + (setq index (1+ right-index)) + (setq previous-line line) + (setq line (make-line :%buffer buffer)) + (setf (line-next previous-line) line) + (setf (line-previous line) previous-line)) + (t + (let* ((length (- end index)) + (chars (make-string length))) + (%sp-byte-blt string index chars 0 length) + (setf (line-chars line) chars)) + (return (renumber-region + (internal-make-region + (mark first-line 0 :right-inserting) + (mark line (length (line-chars line)) + :left-inserting)))))))))) + +(defun line-to-region (line) + "Returns a region containing the specified line." + (internal-make-region (mark line 0 :right-inserting) + (mark line (line-length* line) :left-inserting))) + +(defun previous-character (mark) + "Returns the character immediately before the given Mark." + (let ((line (mark-line mark)) + (charpos (mark-charpos mark))) + (if (= charpos 0) + (if (line-previous line) + #\newline + nil) + (if (eq line open-line) + (char (the simple-string open-chars) + (if (<= charpos left-open-pos) + (1- charpos) + (1- (+ right-open-pos (- charpos left-open-pos))))) + (schar (line-chars line) (1- charpos)))))) + +(defun next-character (mark) + "Returns the character immediately after the given Mark." + (let ((line (mark-line mark)) + (charpos (mark-charpos mark))) + (if (eq line open-line) + (if (= charpos (- line-cache-length (- right-open-pos left-open-pos))) + (if (line-next line) + #\newline + nil) + (schar open-chars + (if (< charpos left-open-pos) + charpos + (+ right-open-pos (- charpos left-open-pos))))) + (let ((chars (line-chars line))) + (if (= charpos (strlen chars)) + (if (line-next line) + #\newline + nil) + (schar chars charpos)))))) + +;;; %Set-Next-Character -- Internal +;;; +;;; This is the setf form for Next-Character. Since we may change a +;;; character to or from a newline, we must be prepared to split and +;;; join lines. We cannot just delete a character and insert the new one +;;; because the marks would not be right. +;;; +(defun %set-next-character (mark character) + (let* ((line (mark-line mark)) + (buffer (line-%buffer line)) + (next (line-next line))) + (modifying-buffer buffer + (modifying-line line mark) + (cond ((= right-open-pos line-cache-length) + ;; The mark is at the end of the line. + (unless next + (error "~S has no next character, so it cannot be set." mark)) + (unless (char= character #\newline) + ;; If the character is no longer a newline then mash two + ;; lines together. + (let ((chars (line-chars next))) + (declare (simple-string chars)) + (setq right-open-pos (- line-cache-length (length chars))) + (when (<= right-open-pos left-open-pos) + (grow-open-chars (* (+ (length chars) left-open-pos 1) 2))) + (%sp-byte-blt chars 0 open-chars right-open-pos + line-cache-length) + (setf (schar open-chars left-open-pos) character) + (incf left-open-pos)) + (move-some-marks (charpos next line) + (+ charpos left-open-pos)) + (setq next (line-next next)) + (setf (line-next line) next) + (when next (setf (line-previous next) line)))) + ((char= character #\newline) + ;; The char is being changed to a newline, so we must split lines. + (incf right-open-pos) + (let* ((len (- line-cache-length right-open-pos)) + (chars (make-string len)) + (new (make-line :chars chars :previous line + :next next :%buffer buffer))) + (%sp-byte-blt open-chars right-open-pos chars 0 len) + (maybe-move-some-marks* (charpos line new) left-open-pos + (- charpos left-open-pos 1)) + (setf (line-next line) new) + (when next (setf (line-previous next) new)) + (setq right-open-pos line-cache-length) + (number-line new))) + (t + (setf (char (the simple-string open-chars) right-open-pos) + character))))) + character) + +;;; %Set-Previous-Character -- Internal +;;; +;;; The setf form for Previous-Character. We just Temporarily move the +;;; mark back one and call %Set-Next-Character. +;;; +(defun %set-previous-character (mark character) + (unless (mark-before mark) + (error "~S has no previous character, so it cannot be set." mark)) + (%set-next-character mark character) + (mark-after mark) + character) + +(defun count-lines (region) + "Returns the number of lines in the region, first and last lines inclusive." + (do ((line (mark-line (region-start region)) (line-next line)) + (count 1 (1+ count)) + (last-line (mark-line (region-end region)))) + ((eq line last-line) count))) + +(defun count-characters (region) + "Returns the number of characters in the region." + (let* ((start (region-start region)) + (end (region-end region)) + (first-line (mark-line start)) + (last-line (mark-line end))) + (if (eq first-line last-line) + (- (mark-charpos end) (mark-charpos start)) + (do ((line (line-next first-line) (line-next line)) + (count (1+ (- (line-length* first-line) (mark-charpos start))))) + ((eq line last-line) + (+ count (mark-charpos end))) + (setq count (+ 1 count (line-length* line))))))) + +(defun line-start (mark &optional line) + "Changes the Mark to point to the beginning of the Line and returns it. + Line defaults to the line Mark is on." + (when line + (change-line mark line)) + (setf (mark-charpos mark) 0) + mark) + +(defun line-end (mark &optional line) + "Changes the Mark to point to the end of the line and returns it. + Line defaults to the line Mark is on." + (if line + (change-line mark line) + (setq line (mark-line mark))) + (setf (mark-charpos mark) (line-length* line)) + mark) + +(defun buffer-start (mark &optional (buffer (line-buffer (mark-line mark)))) + "Change Mark to point to the beginning of Buffer, which defaults to + the buffer Mark is currently in." + (unless buffer (error "Mark ~S does not point into a buffer.")) + (move-mark mark (buffer-start-mark buffer))) + +(defun buffer-end (mark &optional (buffer (line-buffer (mark-line mark)))) + "Change Mark to point to the end of Buffer, which defaults to + the buffer Mark is currently in." + (unless buffer (error "Mark ~S does not point into a buffer.")) + (move-mark mark (buffer-end-mark buffer))) + +(defun move-mark (mark new-position) + "Changes the Mark to point to the same position as New-Position." + (let ((line (mark-line new-position))) + (change-line mark line)) + (setf (mark-charpos mark) (mark-charpos new-position)) + mark) + +(defun mark-before (mark) + "Changes the Mark to point one character before where it currently points. + NIL is returned if there is no previous character." + (let ((charpos (mark-charpos mark))) + (cond ((zerop charpos) + (let ((prev (line-previous (mark-line mark)))) + (when prev + (always-change-line mark prev) + (setf (mark-charpos mark) (line-length* prev)) + mark))) + (t + (setf (mark-charpos mark) (1- charpos)) + mark)))) + +(defun mark-after (mark) + "Changes the Mark to point one character after where it currently points. + NIL is returned if there is no previous character." + (let ((line (mark-line mark)) + (charpos (mark-charpos mark))) + (cond ((= charpos (line-length* line)) + (let ((next (line-next line))) + (when next + (always-change-line mark next) + (setf (mark-charpos mark) 0) + mark))) + (t + (setf (mark-charpos mark) (1+ charpos)) + mark)))) + +(defun character-offset (mark n) + "Changes the Mark to point N characters after (or -N before if N is negative) + where it currently points. If there aren't N characters before (or after) + the mark, Nil is returned." + (let ((charpos (mark-charpos mark))) + (if (< n 0) + (let ((n (- n))) + (if (< charpos n) + (do ((line (line-previous (mark-line mark)) (line-previous line)) + (n (- n charpos 1))) + ((null line) nil) + (let ((length (line-length* line))) + (cond ((<= n length) + (always-change-line mark line) + (setf (mark-charpos mark) (- length n)) + (return mark)) + (t + (setq n (- n (1+ length))))))) + (progn (setf (mark-charpos mark) (- charpos n)) + mark))) + (let* ((line (mark-line mark)) + (length (line-length* line))) + (if (> (+ charpos n) length) + (do ((line (line-next line) (line-next line)) + (n (- n (1+ (- length charpos))))) + ((null line) nil) + (let ((length (line-length* line))) + (cond ((<= n length) + (always-change-line mark line) + (setf (mark-charpos mark) n) + (return mark)) + (t + (setq n (- n (1+ length))))))) + (progn (setf (mark-charpos mark) (+ charpos n)) + mark)))))) + +(defun line-offset (mark n &optional charpos) + "Changes to Mark to point N lines after (-N before if N is negative) where + it currently points. If there aren't N lines after (or before) the Mark, + Nil is returned." + (if (< n 0) + (do ((line (mark-line mark) (line-previous line)) + (n n (1+ n))) + ((null line) nil) + (when (= n 0) + (always-change-line mark line) + (setf (mark-charpos mark) + (if charpos + (min (line-length line) charpos) + (min (line-length line) (mark-charpos mark)))) + (return mark))) + (do ((line (mark-line mark) (line-next line)) + (n n (1- n))) + ((null line) nil) + (when (= n 0) + (change-line mark line) + (setf (mark-charpos mark) + (if charpos + (min (line-length line) charpos) + (min (line-length line) (mark-charpos mark)))) + (return mark))))) + +;;; region-bounds -- Public +;;; +(defun region-bounds (region) + "Return as multiple-value the start and end of Region." + (values (region-start region) (region-end region))) + +(defun set-region-bounds (region start end) + "Set the start and end of Region to the marks Start and End." + (let ((sl (mark-line start)) + (el (mark-line end))) + (when (or (neq (line-%buffer sl) (line-%buffer el)) + (> (line-number sl) (line-number el)) + (and (eq sl el) (> (mark-charpos start) (mark-charpos end)))) + (error "Marks ~S and ~S cannot be made into a region." start end)) + (setf (region-start region) start (region-end region) end)) + region) + + +;;;; Debugging stuff. + +(defun slf (string) + "For a good time, figure out what this function does, and why it was written." + (delete #\linefeed (the simple-string string))) + +(defun %print-whole-line (structure stream) + (cond ((eq structure open-line) + (write-string open-chars stream :end left-open-pos) + (write-string open-chars stream :start right-open-pos + :end line-cache-length)) + (t + (write-string (line-chars structure) stream)))) + +(defun %print-before-mark (mark stream) + (if (mark-line mark) + (let* ((line (mark-line mark)) + (chars (line-chars line)) + (charpos (mark-charpos mark)) + (length (line-length line))) + (declare (simple-string chars)) + (cond ((or (> charpos length) (< charpos 0)) + (write-string "{bad mark}" stream)) + ((eq line open-line) + (cond ((< charpos left-open-pos) + (write-string open-chars stream :end charpos)) + (t + (write-string open-chars stream :end left-open-pos) + (let ((p (+ charpos (- right-open-pos left-open-pos)))) + (write-string open-chars stream :start right-open-pos + :end p))))) + (t + (write-string chars stream :end charpos)))) + (write-string "{deleted mark}" stream))) + + +(defun %print-after-mark (mark stream) + (declare (ignore d)) + (if (mark-line mark) + (let* ((line (mark-line mark)) + (chars (line-chars line)) + (charpos (mark-charpos mark)) + (length (line-length line))) + (declare (simple-string chars)) + (cond ((or (> charpos length) (< charpos 0)) + (write-string "{bad mark}" stream)) + ((eq line open-line) + (cond ((< charpos left-open-pos) + (write-string open-chars stream :start charpos + :end left-open-pos) + (write-string open-chars stream :start right-open-pos + :end line-cache-length)) + (t + (let ((p (+ charpos (- right-open-pos left-open-pos)))) + (write-string open-chars stream :start p + :end line-cache-length))))) + (t + (write-string chars stream :start charpos :end length)))) + (write-string "{deleted mark}" stream))) + +(defun %print-hline (structure stream d) + (declare (ignore d)) + (write-string "#<Hemlock Line \"" stream) + (%print-whole-line structure stream) + (write-string "\">" stream)) + +(defun %print-hmark (structure stream d) + (declare (ignore d)) + (write-string "#<Hemlock Mark \"" stream) + (%print-before-mark structure stream) + (write-string "/\\" stream) + (%print-after-mark structure stream) + (write-string "\">" stream)) + +(defvar *print-region* 10 + "The number of lines to print out of a region, or NIL if none.") + +(defun %print-hregion (region stream d) + (declare (ignore d)) + (write-string "#<Hemlock Region \"" stream) + (let* ((start (region-start region)) + (end (region-end region)) + (first-line (mark-line start)) + (last-line (mark-line end))) + (cond + ((not (and (linep first-line) (linep last-line) + (eq (line-%buffer first-line) (line-%buffer last-line)) + (mark<= start end))) + (write-string "{bad region}" stream)) + (*print-region* + (cond ((eq first-line last-line) + (let ((cs (mark-charpos start)) + (ce (mark-charpos end)) + (len (line-length first-line))) + (cond + ((or (< cs 0) (> ce len)) + (write-string "{bad region}" stream)) + ((eq first-line open-line) + (let ((gap (- right-open-pos left-open-pos))) + (cond + ((<= ce left-open-pos) + (write-string open-chars stream :start cs :end ce)) + ((>= cs left-open-pos) + (write-string open-chars stream :start (+ cs gap) + :end (+ ce gap))) + (t + (write-string open-chars stream :start cs + :end left-open-pos) + (write-string open-chars stream :start right-open-pos + :end (+ gap ce)))))) + (t + (write-string (line-chars first-line) stream :start cs + :end ce))))) + (t + (%print-after-mark start stream) + (write-char #\/ stream) + (do ((line (line-next first-line) (line-next line)) + (last-line (mark-line end)) + (cnt *print-region* (1- cnt))) + ((or (eq line last-line) + (when (zerop cnt) (write-string "..." stream) t)) + (%print-before-mark end stream)) + (%print-whole-line line stream) + (write-char #\/ stream))))) + (t + (write-string "{mumble}" stream)))) + (write-string "\">" stream)) + +(defun %print-hbuffer (structure stream d) + (declare (ignore d)) + (write-string "#<Hemlock Buffer \"" stream) + (write-string (buffer-name structure) stream) + (write-string "\">" stream)) diff --git a/hemlock/htext3.lisp b/hemlock/htext3.lisp new file mode 100644 index 0000000000000000000000000000000000000000..21c5fa4dfb7a425d5fa5f80791f07b30e032c081 --- /dev/null +++ b/hemlock/htext3.lisp @@ -0,0 +1,236 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; More Hemlock Text-Manipulation functions. +;;; Written by Skef Wholey. +;;; +;;; The code in this file implements the insert functions in the +;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document. +;;; + +(in-package "HEMLOCK-INTERNALS") + +(export '(insert-character insert-string insert-region ninsert-region)) + + + +(defun insert-character (mark character) + "Inserts the Character at the specified Mark." + (unless (and character (string-char-p character)) + (error "Character must be non-nil and a string-char -- ~S" character)) + (let* ((line (mark-line mark)) + (buffer (line-%buffer line))) + (modifying-buffer buffer + (modifying-line line mark) + (cond ((char= character #\newline) + (let* ((next (line-next line)) + (new-chars (subseq (the simple-string open-chars) + 0 left-open-pos)) + (new-line (make-line :%buffer buffer + :chars (decf *cache-modification-tick*) + :previous line + :next next))) + (maybe-move-some-marks (charpos line new-line) left-open-pos + (- charpos left-open-pos)) + (setf (line-%chars line) new-chars) + (setf (line-next line) new-line) + (if next (setf (line-previous next) new-line)) + (number-line new-line) + (setq open-line new-line left-open-pos 0))) + (t + (if (= right-open-pos left-open-pos) + (grow-open-chars)) + + (maybe-move-some-marks (charpos line) left-open-pos + (1+ charpos)) + + (cond + ((eq (mark-%kind mark) :right-inserting) + (decf right-open-pos) + (setf (char (the simple-string open-chars) right-open-pos) + character)) + (t + (setf (char (the simple-string open-chars) left-open-pos) + character) + (incf left-open-pos)))))))) + + +(defun insert-string (mark string &optional (start 0) (end (length string))) + "Inserts the String at the Mark. Do not use Start and End unless you + know what you're doing!" + (let* ((line (mark-line mark)) + (buffer (line-%buffer line)) + (string (coerce string 'simple-string))) + (declare (simple-string string)) + (unless (zerop (- end start)) + (modifying-buffer buffer + (modifying-line line mark) + (if (%sp-find-character string start end #\newline) + (with-mark ((mark mark :left-inserting)) + (do ((left-index start (1+ right-index)) + (right-index + (%sp-find-character string start end #\newline) + (%sp-find-character string (1+ right-index) end #\newline))) + ((null right-index) + (if (/= left-index end) + (insert-string mark string left-index end))) + (insert-string mark string left-index right-index) + (insert-character mark #\newline))) + (let ((length (- end start))) + (if (<= right-open-pos (+ left-open-pos end)) + (grow-open-chars (* (+ line-cache-length end) 2))) + + (maybe-move-some-marks (charpos line) left-open-pos + (+ charpos length)) + (cond + ((eq (mark-%kind mark) :right-inserting) + (let ((new (- right-open-pos length))) + (%sp-byte-blt string start open-chars new right-open-pos) + (setq right-open-pos new))) + (t + (let ((new (+ left-open-pos length))) + (%sp-byte-blt string start open-chars left-open-pos new) + (setq left-open-pos new)))))))))) + + +(defconstant line-number-interval-guess 8 + "Our first guess at how we should number an inserted region's lines.") + +(defun insert-region (mark region) + "Inserts the given Region at the Mark." + (let* ((start (region-start region)) + (end (region-end region)) + (first-line (mark-line start)) + (last-line (mark-line end)) + (first-charpos (mark-charpos start)) + (last-charpos (mark-charpos end))) + (cond + ((eq first-line last-line) + ;; simple case -- just BLT the characters in with insert-string + (if (eq first-line open-line) (close-line)) + (insert-string mark (line-chars first-line) first-charpos last-charpos)) + (t + (close-line) + (let* ((line (mark-line mark)) + (next (line-next line)) + (charpos (mark-charpos mark)) + (buffer (line-%buffer line)) + (old-chars (line-chars line))) + (declare (simple-string old-chars)) + (modifying-buffer buffer + ;;hack marked line's chars + (let* ((first-chars (line-chars first-line)) + (first-length (length first-chars)) + (new-length (+ charpos (- first-length first-charpos))) + (new-chars (make-string new-length))) + (declare (simple-string first-chars new-chars)) + (%sp-byte-blt old-chars 0 new-chars 0 charpos) + (%sp-byte-blt first-chars first-charpos new-chars charpos new-length) + (setf (line-chars line) new-chars)) + + ;; Copy intervening lines. We don't link the lines in until we are + ;; done in case the mark is within the region we are inserting. + (do* ((this-line (line-next first-line) (line-next this-line)) + (number (+ (line-number line) line-number-interval-guess) + (+ number line-number-interval-guess)) + (first (%copy-line this-line :previous line + :%buffer buffer :number number)) + (previous first) + (new-line first (%copy-line this-line :previous previous + :%buffer buffer :number number))) + ((eq this-line last-line) + ;;make last line + (let* ((last-chars (line-chars new-line)) + (old-length (length old-chars)) + (new-length (+ last-charpos (- old-length charpos))) + (new-chars (make-string new-length))) + (%sp-byte-blt last-chars 0 new-chars 0 last-charpos) + (%sp-byte-blt old-chars charpos new-chars last-charpos + new-length) + (setf (line-next line) first) + (setf (line-chars new-line) new-chars) + (setf (line-next previous) new-line) + (setf (line-next new-line) next) + (when next + (setf (line-previous next) new-line) + (if (<= (line-number next) number) + (renumber-region-containing new-line))) + ;;fix up the marks + (maybe-move-some-marks (this-charpos line new-line) charpos + (+ last-charpos (- this-charpos charpos))))) + (setf (line-next previous) new-line previous new-line)))))))) + +(defun ninsert-region (mark region) + "Inserts the given Region at the Mark, possibly destroying the Region. + Region may not be a part of any buffer's region." + (let* ((start (region-start region)) + (end (region-end region)) + (first-line (mark-line start)) + (last-line (mark-line end)) + (first-charpos (mark-charpos start)) + (last-charpos (mark-charpos end))) + (cond + ((eq first-line last-line) + ;; Simple case -- just BLT the characters in with insert-string. + (if (eq first-line open-line) (close-line)) + (insert-string mark (line-chars first-line) first-charpos last-charpos)) + (t + (when (bufferp (line-%buffer first-line)) + (error "Region is linked into Buffer ~S." (line-%buffer first-line))) + (close-line) + (let* ((line (mark-line mark)) + (second-line (line-next first-line)) + (next (line-next line)) + (charpos (mark-charpos mark)) + (buffer (line-%buffer line)) + (old-chars (line-chars line))) + (declare (simple-string old-chars)) + (modifying-buffer buffer + ;; Make new chars for first and last lines. + (let* ((first-chars (line-chars first-line)) + (first-length (length first-chars)) + (new-length (+ charpos (- first-length first-charpos))) + (new-chars (make-string new-length))) + (declare (simple-string first-chars new-chars)) + (%sp-byte-blt old-chars 0 new-chars 0 charpos) + (%sp-byte-blt first-chars first-charpos new-chars charpos + new-length) + (setf (line-chars line) new-chars)) + (let* ((last-chars (line-chars last-line)) + (old-length (length old-chars)) + (new-length (+ last-charpos (- old-length charpos))) + (new-chars (make-string new-length))) + (%sp-byte-blt last-chars 0 new-chars 0 last-charpos) + (%sp-byte-blt old-chars charpos new-chars last-charpos new-length) + (setf (line-chars last-line) new-chars)) + + ;;; Link stuff together. + (setf (line-next last-line) next) + (setf (line-next line) second-line) + (setf (line-previous second-line) line) + + ;;Number the inserted stuff and mash any marks. + (do ((line second-line (line-next line)) + (number (+ (line-number line) line-number-interval-guess) + (+ number line-number-interval-guess))) + ((eq line next) + (when next + (setf (line-previous next) last-line) + (if (<= (line-number next) number) + (renumber-region-containing last-line)))) + (when (line-marks line) + (dolist (m (line-marks line)) + (setf (mark-line m) nil)) + (setf (line-marks line) nil)) + (setf (line-number line) number (line-%buffer line) buffer)) + + ;; Fix up the marks in the line inserted into. + (maybe-move-some-marks (this-charpos line last-line) charpos + (+ last-charpos (- this-charpos charpos))))))))) diff --git a/hemlock/killcoms.lisp b/hemlock/killcoms.lisp new file mode 100644 index 0000000000000000000000000000000000000000..52359a858e3a95db0327c92414e17da72c2bf002 --- /dev/null +++ b/hemlock/killcoms.lisp @@ -0,0 +1,487 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Killing and unkilling things. +;;; +;;; Written by Bill Chiles and Rob MacLachlan. +;;; + +(in-package "HEMLOCK") + +(defvar *kill-ring* (make-ring 10) "The Hemlock kill ring.") + + + +;;;; Active Regions. + +(defhvar "Active Regions Enabled" + "When set, some commands that affect the current region only work when the + region is active." + :value t) + +(defhvar "Highlight Active Region" + "When set, the active region will be highlighted on the display if possible." + :value t) + + +(defvar *active-region-p* nil) +(defvar *active-region-buffer* nil) +(defvar *ephemerally-active-command-types* (list :ephemerally-active) + "This is a list of command types that permit the current region to be active + for the immediately following command.") + +(proclaim '(inline activate-region deactivate-region region-active-p)) + +(defun activate-region () + "Make the current region active." + (let ((buffer (current-buffer))) + (setf *active-region-p* (buffer-signature buffer)) + (setf *active-region-buffer* buffer))) + +(defun deactivate-region () + "Make the current region not active." + (setf *active-region-p* nil) + (setf *active-region-buffer* nil)) + +(defun region-active-p () + "Returns t or nil, depending on whether the current region is active." + (or (and *active-region-buffer* + (eql *active-region-p* (buffer-signature *active-region-buffer*))) + (member (last-command-type) *ephemerally-active-command-types* + :test #'equal))) + +(defun check-region-active () + "Signals an error when active regions are enabled and the current region + is not active." + (when (and (value active-regions-enabled) (not (region-active-p))) + (editor-error "The current region is not active."))) + +(defun current-region (&optional (error-if-not-active t) + (deactivate-region t)) + "Returns a region formed by CURRENT-MARK and CURRENT-POINT, optionally + signalling an editor error if the current region is not active. A new + region is cons'ed on each call. This optionally deactivates the region." + (when error-if-not-active (check-region-active)) + (when deactivate-region (deactivate-region)) + (let ((point (current-point)) + (mark (current-mark))) + (if (mark< mark point) (region mark point) (region point mark)))) + + +(defcommand "Activate Region" (p) + "Make the current region active. ^G deactivates the region." + "Make the current region active." + (declare (ignore p)) + (activate-region)) + + +;;; The following are hook functions for keeping things righteous. +;;; + +(defun set-buffer-deactivate-region (buffer) + (declare (ignore buffer)) + (deactivate-region)) +;;; +(add-hook set-buffer-hook 'set-buffer-deactivate-region) + +(defun set-window-deactivate-region (window) + (declare (ignore window)) + (unless (or (eq window *echo-area-window*) + (eq (current-window) *echo-area-window*)) + (deactivate-region))) +;;; +(add-hook set-window-hook 'set-window-deactivate-region) + +(defun control-g-deactivate-region () + (deactivate-region)) +;;; +(add-hook abort-hook 'control-g-deactivate-region) + + + +;;;; Buffer-Mark primitives and commands. + +;;; See Command.Lisp for #'hcmd-make-buffer-hook-fun which makes the +;;; stack for each buffer. + +(defun current-mark () + "Returns the top of the current buffer's mark stack." + (ring-ref (value buffer-mark-ring) 0)) + +(defun buffer-mark (buffer) + "Returns the top of buffer's mark stack." + (ring-ref (variable-value 'buffer-mark-ring :buffer buffer) 0)) + +(defun pop-buffer-mark () + "Pops the current buffer's mark stack, returning the mark. If the stack + becomes empty, a mark is push on the stack pointing to the buffer's start. + This always makes the current region not active." + (let* ((ring (value buffer-mark-ring)) + (mark (ring-pop ring))) + (deactivate-region) + (if (zerop (ring-length ring)) + (ring-push (copy-mark + (buffer-start-mark (current-buffer)) :right-inserting) + ring)) + mark)) + +(defun push-buffer-mark (mark &optional (activate-region nil)) + "Pushes mark into buffer's mark ring, ensuring that the mark is in the right + buffer and :right-inserting. Optionally, the current region is made active. + This never deactivates the current region. Mark is returned." + (cond ((eq (line-buffer (mark-line mark)) (current-buffer)) + (setf (mark-kind mark) :right-inserting) + (ring-push mark (value buffer-mark-ring))) + (t (error "Mark not in the current buffer."))) + (when activate-region (activate-region)) + mark) + +(defcommand "Set/Pop Mark" (p) + "Set or Pop the mark ring. + With no C-U's, pushes point as the mark, activating the current region. + With one C-U's, pops the mark into point, de-activating the current region. + With two C-U's, pops the mark and throws it away, de-activating the current + region." + "Set or Pop the mark ring." + (cond ((not p) + (push-buffer-mark (copy-mark (current-point)) t) + (when (interactive) + (message "Mark pushed."))) + ((= p (value universal-argument-default)) + (pop-and-goto-mark-command nil)) + ((= p (expt (value universal-argument-default) 2)) + (delete-mark (pop-buffer-mark))) + (t (editor-error)))) + +(defcommand "Pop and Goto Mark" (p) + "Pop mark into point, de-activating the current region." + "Pop mark into point." + (declare (ignore p)) + (let ((mark (pop-buffer-mark))) + (move-mark (current-point) mark) + (delete-mark mark))) + +(defcommand "Pop Mark" (p) + "Pop mark and throw it away, de-activating the current region." + "Pop mark and throw it away." + (declare (ignore p)) + (delete-mark (pop-buffer-mark))) + +(defcommand "Exchange Point and Mark" (p) + "Swap the positions of the point and the mark." + "Swap the positions of the point and the mark." + (declare (ignore p)) + (let ((point (current-point)) + (mark (current-mark))) + (with-mark ((temp point)) + (move-mark point mark) + (move-mark mark temp)))) + +(defcommand "Mark Whole Buffer" (p) + "Set the region around the whole buffer, activating the region. + Pushes the point on the mark ring first, so two pops get it back. + With prefix argument, put mark at beginning and point at end." + "Put point at beginning and part at end of current buffer. + If P, do it the other way around." + (let* ((region (buffer-region (current-buffer))) + (start (region-start region)) + (end (region-end region)) + (point (current-point))) + (push-buffer-mark (copy-mark point)) + (cond (p (push-buffer-mark (copy-mark start) t) + (move-mark point end)) + (t (push-buffer-mark (copy-mark end) t) + (move-mark point start))))) + + + +;;;; KILL-REGION and KILL-CHARACTERS primitives. + +(proclaim '(special *delete-char-region*)) + +;;; KILL-REGION first checks for any characters that may need to be added to +;;; the region. If there are some, we possibly push a region onto *kill-ring*, +;;; and we use the top of *kill-ring*. If there are no characters to deal +;;; with, then we make sure the ring isn't empty; if it is, just push our +;;; region. If there is some region in *kill-ring*, then see if the last +;;; command type was a region kill. Otherwise, just push the region. +;;; +(defun kill-region (region current-type) + "Kills the region saving it in *kill-ring*. Current-type is either + :kill-forward or :kill-backward. When LAST-COMMAND-TYPE is one of these, + region is appended or prepended, respectively, to the top of *kill-ring*. + The killing of the region is undo-able with \"Undo\". LAST-COMMAND-TYPE + is set to current-type. This interacts with KILL-CHARACTERS." + (let ((last-type (last-command-type)) + (insert-mark (copy-mark (region-start region) :left-inserting))) + (cond ((or (eq last-type :char-kill-forward) + (eq last-type :char-kill-backward)) + (when *delete-char-region* + (ring-push *delete-char-region* *kill-ring*) + (setf *delete-char-region* nil)) + (setf region (kill-region-top-of-ring region current-type))) + ((zerop (ring-length *kill-ring*)) + (setf region (delete-and-save-region region)) + (ring-push region *kill-ring*)) + ((or (eq last-type :kill-forward) (eq last-type :kill-backward)) + (setf region (kill-region-top-of-ring region current-type))) + (t + (setf region (delete-and-save-region region)) + (ring-push region *kill-ring*))) + (make-region-undo :insert "kill" (copy-region region) insert-mark) + (setf (last-command-type) current-type))) + +(defun kill-region-top-of-ring (region current-type) + (let ((r (ring-ref *kill-ring* 0))) + (ninsert-region (if (eq current-type :kill-forward) + (region-end r) + (region-start r)) + (delete-and-save-region region)) + r)) + +(defhvar "Character Deletion Threshold" + "When this many characters are deleted contiguously via KILL-CHARACTERS, + they are saved on the kill ring -- for example, \"Delete Next Character\", + \"Delete Previous Character\", or \"Delete Previous Character Expanding + Tabs\"." + :value 5) + +(defvar *delete-char-region* nil) +(defvar *delete-char-count* 0) + +;;; KILL-CHARACTERS makes sure there are count characters with CHARACTER-OFFSET. +;;; If the last command type was a region kill, we just use the top region +;;; in *kill-ring* by making KILL-CHAR-REGION believe *delete-char-count* is +;;; over the threshold. We don't call KILL-REGION in this case to save making +;;; undo's -- no good reason. If we were just called, then increment our +;;; global counter. Otherwise, make an empty region to keep KILL-CHAR-REGION +;;; happy and increment the global counter. +;;; +(defun kill-characters (mark count) + "Kills count characters after mark if positive, before mark if negative. + If called multiple times contiguously such that the sum of the count values + equals \"Character Deletion Threshold\", then the characters are saved on + *kill-ring*. This relies on setting LAST-COMMAND-TYPE, and it interacts + with KILL-REGION. If there are not count characters in the appropriate + direction, no characters are deleted, and nil is returned; otherwise, mark + is returned." + (if (zerop count) + mark + (with-mark ((temp mark :left-inserting)) + (if (character-offset temp count) + (let ((current-type (if (plusp count) + :char-kill-forward + :char-kill-backward)) + (last-type (last-command-type)) + (del-region (if (mark< temp mark) + (region temp mark) + (region mark temp)))) + (cond ((or (eq last-type :kill-forward) + (eq last-type :kill-backward)) + (setf *delete-char-count* + (value character-deletion-threshold)) + (setf *delete-char-region* nil)) + ((or (eq last-type :char-kill-backward) + (eq last-type :char-kill-forward)) + (incf *delete-char-count* (abs count))) + (t + (setf *delete-char-region* (make-empty-region)) + (setf *delete-char-count* (abs count)))) + (kill-char-region del-region current-type) + mark) + nil)))) + +(defun kill-char-region (region current-type) + (let ((deleted-region (delete-and-save-region region))) + (cond ((< *delete-char-count* (value character-deletion-threshold)) + (ninsert-region (if (eq current-type :char-kill-forward) + (region-end *delete-char-region*) + (region-start *delete-char-region*)) + deleted-region) + (setf (last-command-type) current-type)) + (t + (when *delete-char-region* + (ring-push *delete-char-region* *kill-ring*) + (setf *delete-char-region* nil)) + (let ((r (ring-ref *kill-ring* 0))) + (ninsert-region (if (eq current-type :char-kill-forward) + (region-end r) + (region-start r)) + deleted-region)) + (setf (last-command-type) + (if (eq current-type :char-kill-forward) + :kill-forward + :kill-backward)))))) + + + +;;;; Commands. + +(defcommand "Kill Region" (p) + "Kill the region, pushing on the kill ring. + If the region is not active nor the last command a yank, signal an error." + "Kill the region, pushing on the kill ring." + (declare (ignore p)) + (kill-region (current-region) + (if (mark< (current-mark) (current-point)) + :kill-backward + :kill-forward))) + +(defcommand "Save Region" (p) + "Insert the region into the kill ring. + If the region is not active nor the last command a yank, signal an error." + "Insert the region into the kill ring." + (declare (ignore p)) + (ring-push (copy-region (current-region)) *kill-ring*)) + +(defcommand "Kill Next Word" (p) + "Kill a word at the point. + With prefix argument delete that many words. The text killed is + appended to the text currently at the top of the kill ring if it was + next to the text being killed." + "Kill p words at the point" + (let ((point (current-point)) + (num (or p 1))) + (with-mark ((mark point :temporary)) + (if (word-offset mark num) + (if (minusp num) + (kill-region (region mark point) :kill-backward) + (kill-region (region point mark) :kill-forward)) + (editor-error))))) + +(defcommand "Kill Previous Word" (p) + "Kill a word before the point. + With prefix argument kill that many words before the point. The text + being killed is appended to the text currently at the top of the kill + ring if it was next to the text being killed." + "Kill p words before the point" + (kill-next-word-command (- (or p 1)))) + + +(defcommand "Kill Line" (p) + "Kills the characters to the end of the current line. + If the line is empty then the line is deleted. With prefix argument, + deletes that many lines past the point (or before if the prefix is negative)." + "Kills p lines after the point." + (let* ((point (current-point)) + (line (mark-line point))) + (with-mark ((mark point)) + (cond + (p + (when (and (/= (mark-charpos point) 0) (minusp p)) + (incf p)) + (unless (line-offset mark p 0) + (if (plusp p) + (kill-region (region point (buffer-end mark)) :kill-forward) + (kill-region (region (buffer-start mark) point) :kill-backward)) + (editor-error)) + (if (plusp p) + (kill-region (region point mark) :kill-forward) + (kill-region (region mark point) :kill-backward))) + (t + (cond ((not (blank-after-p mark)) + (line-end mark)) + ((line-next line) + (line-start mark (line-next line))) + ((not (end-line-p mark)) + (line-end mark)) + (t + (editor-error))) + (kill-region (region point mark) :kill-forward)))))) + +(defcommand "Backward Kill Line" (p) + "Kill from the point to the beginning of the line. + If at the beginning of the line, kill the newline and any trailing space + on the previous line. With prefix argument, call \"Kill Line\" with + the argument negated." + "Kills p lines before the point." + (if p + (kill-line-command (- p)) + (with-mark ((m (current-point))) + (cond ((zerop (mark-charpos m)) + (mark-before m) + (unless (reverse-find-attribute m :space #'zerop) + (buffer-start m))) + (t + (line-start m))) + (kill-region (region m (current-point)) :kill-backward)))) + + +(defcommand "Delete Blank Lines" (p) + "On a blank line, deletes all surrounding blank lines, leaving just + one. On an isolated blank line, deletes that one. On a non-blank line, + deletes all blank following that one." + "Kill blank lines around the point" + (declare (ignore p)) + (let ((point (current-point))) + (with-mark ((beg-mark point :left-inserting) + (end-mark point :right-inserting)) + ;; handle case when the current line is blank + (when (blank-line-p (mark-line point)) + ;; back up to last non-whitespace character + (reverse-find-attribute beg-mark :whitespace #'zerop) + (when (previous-character beg-mark) + ;; that is, we didn't back up to the beginning of the buffer + (unless (same-line-p beg-mark end-mark) + (line-offset beg-mark 1 0))) + ;; if isolated, zap the line else zap the blank ones above + (cond ((same-line-p beg-mark end-mark) + (line-offset end-mark 1 0)) + (t + (line-start end-mark))) + (delete-region (region beg-mark end-mark))) + ;; always delete all blank lines after the current line + (move-mark beg-mark point) + (when (line-offset beg-mark 1 0) + (move-mark end-mark beg-mark) + (find-attribute end-mark :whitespace #'zerop) + (when (next-character end-mark) + ;; that is, we didn't go all the way to the end of the buffer + (line-start end-mark)) + (delete-region (region beg-mark end-mark)))))) + + +(defcommand "Un-Kill" (p) + "Inserts the top item in the kill-ring at the point. + The mark is left mark before the insertion and the point after. With prefix + argument inserts the prefix'th most recent item." + "Inserts the item with index p in the kill ring at the point, leaving + the mark before and the point after." + (let ((idx (1- (or p 1)))) + (cond ((> (ring-length *kill-ring*) idx -1) + (let* ((region (ring-ref *kill-ring* idx)) + (point (current-point)) + (mark (copy-mark point))) + (push-buffer-mark mark) + (insert-region point region) + (make-region-undo :delete "Un-Kill" + (region (copy-mark mark) (copy-mark point)))) + (setf (last-command-type) :unkill)) + (t (editor-error))))) +;;; +(push :unkill *ephemerally-active-command-types*) + +(defcommand "Rotate Kill Ring" (p) + "Replace un-killed text with previously killed text. + Kills the current region, rotates the kill ring, and inserts the new top + item. With prefix argument rotates the kill ring that many times." + "This function will not behave in any reasonable fashion when + called as a lisp function." + (let ((point (current-point)) + (mark (current-mark))) + (cond ((or (not (eq (last-command-type) :unkill)) + (zerop (ring-length *kill-ring*))) + (editor-error)) + (t (delete-region (region mark point)) + (rotate-ring *kill-ring* (or p 1)) + (insert-region point (ring-ref *kill-ring* 0)) + (make-region-undo :delete "Un-Kill" + (region (copy-mark mark) (copy-mark point))) + (setf (last-command-type) :unkill))))) diff --git a/hemlock/line.lisp b/hemlock/line.lisp new file mode 100644 index 0000000000000000000000000000000000000000..f5eb2e963fd49b1e67322441ce4d6b2d4b173fa0 --- /dev/null +++ b/hemlock/line.lisp @@ -0,0 +1,167 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains definitions for the Line structure, and some +;;; functions and macros to manipulate them. +;;; +;;; This stuff was allowed to become implementation dependant because +;;; you make thousands of lines, so speed is real important. In some +;;; implementations (the Perq for example) it may be desirable to +;;; not actually cons the strings in the line objects until someone +;;; touches them, and just keep a pointer in the line to where the file +;;; is mapped in memory. Such lines are called "buffered". This stuff +;;; links up with the file-reading stuff and the line-image building stuff. +;;; +(in-package 'hemlock-internals) +(export '(line linep line-previous line-next line-plist line-signature)) + +(setf (documentation 'linep 'function) + "Returns true if its argument is a Hemlock line object, Nil otherwise.") +(setf (documentation 'line-previous 'function) + "Return the Hemlock line that precedes this one, or Nil if there is no + previous line.") +(setf (documentation 'line-next 'function) + "Return the Hemlock line that follows this one, or Nil if there is no + next line.") +(setf (documentation 'line-plist 'function) + "Return a line's property list. This may be manipulated with Setf and Getf.") + + +;;;; The line object: + +(defstruct (line (:print-function %print-hline) + (:predicate linep) + (:constructor nil)) + "A Hemlock line object. See Hemlock design document for details." + ;; + ;; Something that represents the contents of the line. This is + ;; guaranteed to change (as compared by EQL) whenver the contents of the + ;; line changes, but might at arbitarary other times. There are + ;; currently about three different cases: + ;; + ;; Normal: + ;; A simple string holding the contents of the line. + ;; + ;; A cached line: + ;; The line is eq to Open-Line, and the actual contents are in the + ;; line cache. The %Chars may be either the original contents or a + ;; negative fixnum. + ;; + ;; A buffered line: + ;; The line hasn't been touched since it was read from a file, and the + ;; actual contents are in some system I/O area. This is indicated by + ;; the Line-Buffered-P slot being true. In buffered lines on the RT, + ;; the %Chars slot contains the system-area-pointer to the beginning + ;; of the characters. + (%chars "") + ;; + ;; Pointers to the next and previous lines in the doubly linked list of + ;; line structures. + previous + next + ;; + ;; A list of all the permanent marks pointing into this line. + (marks ()) + ;; + ;; The buffer to which this line belongs, or a *disembodied-buffer-count* + ;; if the line is not in any buffer. + %buffer + ;; + ;; A non-negative integer (fixnum) that represents the ordering of lines + ;; within continguous range of lines (a buffer or disembuffered region). + ;; The number of the Line-Next is guaranteed to be strictly greater than + ;; our number, and the Line-Previous is guaranteed to be strictly less. + (number 0) + ;; + ;; The line property list, used by user code to annotate the text. + plist + ;; + ;; A slot that indicates whether this line is a buffered line, and if so + ;; contains information about how the text is stored. On the RT, this is + ;; the length of the text pointed to by the Line-%Chars. + #+Buffered-Lines + (buffered-p ())) + +;;; Make Line-Chars the same as Line-%Chars on implementations without +;;; buffered lines. +;;; +#-Buffered-Lines +(defmacro line-chars (x) + `(line-%chars ,x)) + + +;;; If buffered lines are supported, then we create the string +;;; representation for the characters when someone uses Line-Chars. People +;;; who are prepared to handle buffered lines or who just want a signature +;;; for the contents can use Line-%chars directly. +;;; +#+Buffered-Lines +(defmacro line-chars (line) + `(the simple-string (if (line-buffered-p ,line) + (read-buffered-line ,line) + (line-%chars ,line)))) +;;; +#+Buffered-Lines +(defsetf line-chars %set-line-chars) +;;; +#+Buffered-Lines +(defmacro %set-line-chars (line chars) + `(setf (line-%chars ,line) ,chars)) + + +;;; Line-Signature -- Public +;;; +;;; We can just return the Line-%Chars. +;;; +(proclaim '(inline line-signature)) +(defun line-signature (line) + "This function returns an object which serves as a signature for a line's + contents. It is guaranteed that any modification of text on the line will + result in the signature changing so that it is not EQL to any previous value. + Note that the signature may change even when the text hasn't been modified, but + this probably won't happen often." + (line-%chars line)) + + +;;; Fast version of Make-Line does keyword hacking at compile time. +;;; +(defmacro make-line (&key chars previous next marks %buffer number + plist #+Buffered-Lines buffered-p) + `(lisp::%sp-set-vector-subtype + (vector 'line + ,chars + ,previous + ,next + ,marks + ,%buffer + ,number + ,plist + #+Buffered-Lines ,buffered-p) + 1)) + +;;; Return a copy of Line in buffer Buffer with the same chars. We use +;;; this macro where we want to copy a line because it takes care of +;;; the case where the line is buffered. +;;; +(defmacro %copy-line (line &key previous number %buffer) + `(make-line :chars (line-%chars ,line) + :previous ,previous + :number ,number + :%buffer ,%buffer + #+Buffered-Lines :buffered-p + #+Buffered-Lines (line-buffered-p ,line))) + +(defmacro line-length* (line) + "Returns the number of characters on the line, but it's a macro!" + `(cond ((eq ,line open-line) + (+ left-open-pos (- line-cache-length right-open-pos))) + ((line-buffered-p ,line)) + (t + (length (the simple-string (line-%chars ,line)))))) diff --git a/hemlock/linimage.lisp b/hemlock/linimage.lisp new file mode 100644 index 0000000000000000000000000000000000000000..504aedfedf406672ed47b6936cf6d43a31bf88bf --- /dev/null +++ b/hemlock/linimage.lisp @@ -0,0 +1,508 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; +;;; This file contains functions related to building line images. +;;; +(in-package 'hemlock-internals) + +;;; The code in here is factored out in this way because it is more +;;; or less implementation dependant. The reason this code is +;;; implementation dependant is not because it is not written in +;;; Common Lisp per se, but because it uses this thing called +;;; %SP-Find-Character-With-Attribute to find any characters that +;;; are to be displayed on the line which do not print as themselves. +;;; This permits us to have an arbitrary string or even string-valued +;;; function to as the representation for such a "Funny" character +;;; with minimal penalty for the normal case. This function can be written +;;; in lisp, and is included commented-out below, but if this function +;;; is not real fast then redisplay performance will suffer. +;;; +;;; Theres also code in here that special-cases "Buffered" lines, +;;; which is not exactly Common Lisp, but if you aren't on a perq, +;;; you won't have to worry about it. +;;; +;(defun %sp-find-character-with-attribute (string start end table mask) +; (declare (type (simple-array (mod 256) char-code-max) table)) +; (declare (simple-string string)) +; (declare (fixnum start end)) +; "%SP-Find-Character-With-Attribute String, Start, End, Table, Mask +; The codes of the characters of String from Start to End are used as indices +; into the Table, which is a U-Vector of 8-bit bytes. When the number picked +; up from the table bitwise ANDed with Mask is non-zero, the current +; index into the String is returned. The corresponds to SCANC on the Vax." +; (do ((index start (1+ index))) +; ((= index end) nil) +; (declare (fixnum index)) +; (if (/= (logand (aref table (char-code (elt string index))) mask) 0) +; (return index)))) +; +;(defun %sp-reverse-find-character-with-attribute (string start end table +; mask) +; (declare (type (simple-array (mod 256) char-code-max) table)) +; (declare (simple-string string)) +; (declare (fixnum start end)) +; "Like %SP-Find-Character-With-Attribute, only sdrawkcaB." +; (do ((index (1- end) (1- index))) +; ((< index start) nil) +; (declare (fixnum index)) +; (if (/= (logand (aref table (char-code (elt string index))) mask) 0) +; (return index)))) + +(defconstant winning-char #b01 "Bit for a char that prints normally") +(defconstant losing-char #b10 "Bit for char with funny representation.") +(defvar *losing-character-mask* + (make-array char-code-limit :element-type '(mod 256) + :initial-element winning-char) + "This is a character set used by redisplay to find funny chars.") +(defvar *print-representation-vector* nil + "Redisplay's handle on the :print-representation attribute") + +;;; Do a find-character-with-attribute on the *losing-character-mask*. +(defmacro %fcwa (str start end mask) + `(%sp-find-character-with-attribute + ,str ,start ,end *losing-character-mask* ,mask)) + +;;; Get the print-representation of a character. +(defmacro get-rep (ch) + `(svref *print-representation-vector* (char-code ,ch))) + + + +(proclaim '(special *character-attributes*)) + +;;; %init-line-image -- Internal +;;; +;;; Set up the print-representations for funny chars. We make the +;;; attribute vector by hand and do funny stuff so that chars > 127 +;;; will have a losing print-representation, so redisplay will not +;;; die if you visit a binary file or do something stupid like that. +;;; +(defun %init-line-image () + (defattribute "Print Representation" + "The value of this attribute determines how a character is displayed + on the screen. If the value is a string this string is literally + displayed. If it is a function, then that function is called with + the current X position to get the string to display.") + (setq *print-representation-vector* (make-array char-code-limit)) + (setf (attribute-descriptor-vector + (gethash :print-representation *character-attributes*)) + *print-representation-vector*) + (do ((code syntax-char-code-limit (1+ code)) + (str (make-string 4) (make-string 4))) + ((= code char-code-limit)) + (setf (aref *losing-character-mask* code) losing-char) + (setf (aref *print-representation-vector* code) str) + (setf (schar str 0) #\<) + (setf (schar str 1) (char-upcase (digit-char (ash code -4) 16))) + (setf (schar str 2) (char-upcase (digit-char (logand code #x+F) 16))) + (setf (schar str 3) #\>)) + + (add-hook ed::character-attribute-hook + #'redis-set-char-attribute-hook-fun) + (do ((i (1- (char-code #\space)) (1- i)) str) + ((minusp i)) + (setq str (make-string 2)) + (setf (elt (the simple-string str) 0) #\^) + (setf (elt (the simple-string str) 1) + (code-char (+ i (char-code #\@)))) + (setf (character-attribute :print-representation (code-char i)) str)) + (setf (character-attribute :print-representation (code-char #o177)) "^?") + (setf (character-attribute :print-representation #\tab) + #'redis-tab-display-fun)) + +;;; redis-set-char-attribute-hook-fun +;;; +;;; Keep track of which characters have funny representations. +;;; +(defun redis-set-char-attribute-hook-fun (attribute char new-value) + (when (eq attribute :print-representation) + (cond + ((simple-string-p new-value) + (if (and (= (length (the simple-string new-value)) 1) + (char= char (elt (the simple-string new-value) 0))) + (setf (aref *losing-character-mask* (char-code char)) winning-char) + (setf (aref *losing-character-mask* (char-code char)) + losing-char))) + ((functionp new-value) + (setf (aref *losing-character-mask* (char-code char)) losing-char)) + (t (error "Bad print representation: ~S" new-value))))) + +;;; redis-tab-display-fun +;;; +;;; This function is initially the :print-representation for tab. +;;; +(defun redis-tab-display-fun (xpos) + (svref '#(" " + " " + " " + " " + " " + " " + " " + " ") + (logand xpos 7))) + + +;;;; The actual line image computing functions. +;;;; + +(eval-when (compile eval) +;;; display-some-chars -- internal +;;; +;;; Put some characters into a window. Characters from src-start +;;; to src-end in src are are put in the window's dis-line's. Lines +;;; are wrapped as necessary. dst is the dis-line-chars of the dis-line +;;; currently being written. Dis-lines is the window's vector of dis-lines. +;;; dis-line is the dis-line currently being written. Line is the index +;;; into dis-lines of the current dis-line. dst-start is the index to +;;; start writing chars at. Height and width are the height and width of the +;;; window. src-start, dst, dst-start, line and dis-line are updated. +;;; Done-P indicates whether there are more characters after this sequence. +;;; +(defmacro display-some-chars (src src-start src-end dst dst-start width done-p) + `(let ((dst-end (+ ,dst-start (- ,src-end ,src-start)))) + (declare (fixnum dst-end)) + (cond + ((>= dst-end ,width) + (cond + ((and ,done-p (= dst-end ,width)) + (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end) + (setq ,dst-start dst-end ,src-start ,src-end)) + (t + (let ((1-width (1- ,width))) + (%sp-byte-blt ,src ,src-start ,dst ,dst-start 1-width) + (setf (elt (the simple-string ,dst) 1-width) *line-wrap-char*) + (setq ,src-start (+ ,src-start (- 1-width ,dst-start))) + (setq ,dst-start nil))))) + (t (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end) + (setq ,dst-start dst-end ,src-start ,src-end))))) + +;;; These macros are given as args to display-losing-chars to get the +;;; print representation of whatever is in the data vector. +(defmacro string-get-rep (string index) + `(get-rep (schar ,string ,index))) + +(defmacro u-vec-get-rep (u-vec index) + `(svref *print-representation-vector* + (%primitive 8bit-system-ref ,u-vec ,index))) + +;;; display-losing-chars -- Internal +;;; +;;; This macro is called by the compute-line-image functions to +;;; display a group of losing characters. +;;; +(defmacro display-losing-chars (line-chars index end dest xpos width + string underhang access-fun + &optional (done-p `(= ,index ,end))) + `(do ((last (or (%fcwa ,line-chars ,index ,end winning-char) ,end)) + str len zero) + (()) + (declare (fixnum last len zero)) + (setq str (,access-fun ,line-chars ,index)) + (unless (simple-string-p str) (setq str (funcall str ,xpos))) + (setq len (strlen str) zero 0) + (incf ,index) + (display-some-chars str zero len ,dest ,xpos ,width ,done-p) + (cond ((not ,xpos) + ;; We wrapped in the middle of a losing char. + (setq ,underhang zero ,string str) + (return nil)) + ((= ,index last) + ;; No more losing chars in this bunch. + (return nil))))) + +(defmacro update-and-punt (dis-line length string underhang end) + `(progn (setf (dis-line-length ,dis-line) ,length) + (return (values ,string ,underhang + (setf (dis-line-end ,dis-line) ,end))))) + +); eval-when (compile eval) + +;;; compute-normal-line-image -- Internal +;;; +;;; Compute the screen representation of Line starting at Start +;;; putting it in Dis-Line beginning at Xpos. Width is the width of the +;;; window we are displaying in. If the line will wrap then we display +;;; as many chars as we can then put in *line-wrap-char*. The values +;;; returned are described in Compute-Line-Image, which tail-recursively +;;; returns them. The length slot in Dis-Line is updated. +;;; +;;; We use the *losing-character-mask* to break the line to be displayed +;;; up into chunks of characters with normal print representation and +;;; those with funny representations. +;;; +(defun compute-normal-line-image (line start dis-line xpos width) + (declare (fixnum start xpos width)) + (do* ((index start) + (line-chars (line-%chars line)) + (end (strlen line-chars)) + (dest (dis-line-chars dis-line)) losing underhang string) + (()) + (declare (fixnum index end losing) + (simple-string line-chars dest)) + (cond + (underhang + (update-and-punt dis-line width string underhang index)) + ((null xpos) + (update-and-punt dis-line width nil 0 index)) + ((= index end) + (update-and-punt dis-line xpos nil nil index))) + (setq losing (%fcwa line-chars index end losing-char)) + (when (null losing) + (display-some-chars line-chars index end dest xpos width t) + (if (or xpos (= index end)) + (update-and-punt dis-line xpos nil nil index) + (update-and-punt dis-line width nil 0 index))) + (display-some-chars line-chars index losing dest xpos width nil) + (cond + ;; Did we wrap? + ((null xpos) + (update-and-punt dis-line width nil 0 index)) + ;; Are we about to cause the line to wrap? If so, wrap before + ;; it's too late. + ((= xpos width) + (setf (char dest (1- width)) *line-wrap-char*) + (update-and-punt dis-line width nil 0 index)) + (t + (display-losing-chars line-chars index end dest xpos width string + underhang string-get-rep))))) + +;;; compute-buffered-line-image -- Internal +;;; +;;; Compute the line image for a "Buffered" line, that is, one whose +;;; chars have not been consed yet. + +(defun compute-buffered-line-image (line start dis-line xpos width) + (declare (fixnum start xpos width)) + (do* ((index start) + (line-chars (line-%chars line)) + (end (line-buffered-p line)) + (dest (dis-line-chars dis-line)) losing underhang string) + (()) + (declare (fixnum index end losing) + (simple-string line-chars dest)) + (cond + (underhang + (update-and-punt dis-line width string underhang index)) + ((null xpos) + (update-and-punt dis-line width nil 0 index)) + ((= index end) + (update-and-punt dis-line xpos nil nil index))) + (setq losing (%fcwa line-chars index end losing-char)) + (when (null losing) + (display-some-chars line-chars index end dest xpos width t) + (if (or xpos (= index end)) + (update-and-punt dis-line xpos nil nil index) + (update-and-punt dis-line width nil 0 index))) + (display-some-chars line-chars index losing dest xpos width nil) + (cond + ;; Did we wrap? + ((null xpos) + (update-and-punt dis-line width nil 0 index)) + ;; Are we about to cause the line to wrap? If so, wrap before + ;; it's too late. + ((= xpos width) + (setf (char dest (1- width)) *line-wrap-char*) + (update-and-punt dis-line width nil 0 index)) + (t + (display-losing-chars line-chars index end dest xpos width string + underhang u-vec-get-rep))))) + +;;; compute-cached-line-image -- Internal +;;; +;;; Like compute-normal-line-image, only works on the cached line. +;;; +(defun compute-cached-line-image (index dis-line xpos width) + (declare (fixnum start xpos width)) + (prog ((gap (- right-open-pos left-open-pos)) + (dest (dis-line-chars dis-line)) + (done-p (= right-open-pos line-cache-length)) + losing string underhang) + (declare (fixnum index gap losing) (simple-string dest)) + LEFT-LOOP + (cond + (underhang + (update-and-punt dis-line width string underhang index)) + ((null xpos) + (update-and-punt dis-line width nil 0 index)) + ((>= index left-open-pos) + (go RIGHT-START))) + (setq losing (%fcwa open-chars index left-open-pos losing-char)) + (cond + (losing + (display-some-chars open-chars index losing dest xpos width nil) + ;; If we we didn't wrap then display some losers... + (if xpos + (display-losing-chars open-chars index left-open-pos dest xpos + width string underhang string-get-rep + (and done-p (= index left-open-pos))) + (update-and-punt dis-line width nil 0 index))) + (t + (display-some-chars open-chars index left-open-pos dest xpos width done-p))) + (go LEFT-LOOP) + + RIGHT-START + (setq index (+ index gap)) + RIGHT-LOOP + (cond + (underhang + (update-and-punt dis-line width string underhang (- index gap))) + ((null xpos) + (update-and-punt dis-line width nil 0 (- index gap))) + ((= index line-cache-length) + (update-and-punt dis-line xpos nil nil (- index gap)))) + (setq losing (%fcwa open-chars index line-cache-length losing-char)) + (cond + (losing + (display-some-chars open-chars index losing dest xpos width nil) + (cond + ;; Did we wrap? + ((null xpos) + (update-and-punt dis-line width nil 0 (- index gap))) + (t + (display-losing-chars open-chars index line-cache-length dest xpos + width string underhang string-get-rep)))) + (t + (display-some-chars open-chars index line-cache-length dest xpos width t))) + (go RIGHT-LOOP))) + +(defun make-some-font-changes () + (do ((res nil (make-font-change res)) + (i 42 (1- i))) + ((zerop i) res))) + +(defvar *free-font-changes* (make-some-font-changes) + "Font-Change structures that nobody's using at the moment.") + +(defmacro alloc-font-change (x font mark) + `(progn + (unless *free-font-changes* + (setq *free-font-changes* (make-some-font-changes))) + (let ((new-fc *free-font-changes*)) + (setq *free-font-changes* (font-change-next new-fc)) + (setf (font-change-x new-fc) ,x + (font-change-font new-fc) ,font + (font-change-next new-fc) nil + (font-change-mark new-fc) ,mark) + new-fc))) + +;;; +;;; compute-line-image -- Internal +;;; +;;; This function builds a full line image from some characters in +;;; a line and from some characters which may be left over from the previous +;;; line. +;;; +;;; Parameters: +;;; String - This is the string which contains the characters left over +;;; from the previous line. This is NIL if there are none. +;;; Underhang - Characters from here to the end of String are put at the +;;; beginning of the line image. +;;; Line - This is the line to display characters from. +;;; Offset - This is the index of the first character to display in Line. +;;; Dis-Line - This is the dis-line to put the line-image in. The only +;;; slots affected are the chars and the length. +;;; Width - This is the width of the field to display in. +;;; +;;; Three values are returned: +;;; 1) The new overhang string, if none this is NIL. +;;; 2) The new underhang, if this is NIL then the entire line was +;;; displayed. If the entire line was not displayed, but there was no +;;; underhang, then this is 0. +;;; 3) The index in line after the last character displayed. +;;; +(defun compute-line-image (string underhang line offset dis-line width) + ;; + ;; Release any old font-changes. + (let ((changes (dis-line-font-changes dis-line))) + (when changes + (do ((prev changes current) + (current (font-change-next changes) + (font-change-next current))) + ((null current) + (setf (dis-line-font-changes dis-line) nil) + (shiftf (font-change-next prev) *free-font-changes* changes)) + (setf (font-change-mark current) nil)))) + ;; + ;; If the line has any Font-Marks, add Font-Changes for them. + (let ((marks (line-marks line))) + (when (dolist (m marks nil) + (when (fast-font-mark-p m) (return t))) + (let ((prev nil)) + ;; + ;; Find the last Font-Mark with charpos less than Offset. If there is + ;; such a Font-Mark, then there is a font-change to this font at X = 0. + (let ((max -1) + (max-mark nil)) + (dolist (m marks) + (when (fast-font-mark-p m) + (let ((charpos (mark-charpos m))) + (when (and (< charpos offset) (> charpos max)) + (setq max charpos max-mark m))))) + (when max-mark + (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark)) + (setf (dis-line-font-changes dis-line) prev))) + ;; + ;; Repeatedly scan through marks, adding a font-change for the + ;; smallest Font-Mark with a charpos greater than Bound, until + ;; we find no such mark. + (do ((bound (1- offset) min) + (min most-positive-fixnum most-positive-fixnum) + (min-mark nil nil)) + (()) + (dolist (m marks) + (when (fast-font-mark-p m) + (let ((charpos (mark-charpos m))) + (when (and (> charpos bound) (< charpos min)) + (setq min charpos min-mark m))))) + (unless min-mark (return nil)) + (let ((len (if (eq line open-line) + (cached-real-line-length line 10000 offset min) + (real-line-length line 10000 offset min)))) + (when (< len width) + (let ((new (alloc-font-change + (+ len + (if string + (- (length (the simple-string string)) underhang) + 0)) + (font-mark-font min-mark) + min-mark))) + (if prev + (setf (font-change-next prev) new) + (setf (dis-line-font-changes dis-line) new)) + (setq prev new)))))))) + ;; + ;; Recompute the line image. + (cond + (string + (let ((len (strlen string)) + (chars (dis-line-chars dis-line)) + (xpos 0)) + (declare (fixnum xpos len) (simple-string chars)) + (display-some-chars string underhang len chars xpos width nil) + (cond + ((null xpos) + (values string underhang offset)) + ((eq line open-line) + (compute-cached-line-image offset dis-line xpos width)) + #+Buffered-Lines + ((line-buffered-p line) + (compute-buffered-line-image line offset dis-line xpos width)) + (t + (compute-normal-line-image line offset dis-line xpos width))))) + ((eq line open-line) + (compute-cached-line-image offset dis-line 0 width)) + #+Buffered-Lines + ((line-buffered-p line) + (compute-buffered-line-image line offset dis-line 0 width)) + (t + (compute-normal-line-image line offset dis-line 0 width)))) diff --git a/hemlock/lispbuf.lisp b/hemlock/lispbuf.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3def78bff75313afcc7b4d54ba4ca71c4b7785ed --- /dev/null +++ b/hemlock/lispbuf.lisp @@ -0,0 +1,766 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Stuff to do a little lisp hacking in the editor's Lisp environment. +;;; + +(in-package "HEMLOCK") + + +(defmacro in-lisp (&body body) + "Evaluates body inside HANDLE-LISP-ERRORS. *package* is bound to the package + named by \"Current Package\" if it is non-nil." + (let ((name (gensym)) (package (gensym))) + `(handle-lisp-errors + (let* ((,name (value current-package)) + (,package (and ,name (find-package ,name)))) + (progv (if ,package '(*package*)) (if ,package (list ,package)) + ,@body))))) + + +(define-file-option "Package" (buffer value) + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer + :value + (let* ((eof (list nil)) + (thing (read-from-string value nil eof))) + (when (eq thing eof) (error "Bad package file option value.")) + (cond + ((stringp thing) + thing) + ((symbolp thing) + (symbol-name thing)) + ((and (characterp thing) (string-char-p thing)) + (string thing)) + (t + (message + "Ignoring \"package\" file option -- cannot convert to a string.")))))) + + +;;;; Eval Mode Interaction. + +(proclaim '(special * ** *** - + ++ +++ / // /// *prompt*)) + +(defun setup-eval-mode (buffer) + (let ((point (buffer-point buffer))) + (setf (buffer-minor-mode buffer "Eval") t) + (setf (buffer-minor-mode buffer "Editor") t) + (setf (buffer-major-mode buffer) "Lisp") + (buffer-end point) + (defhvar "Current Package" + "This variable holds the name of the package currently used for Lisp + evaluation and compilation. If it is Nil, the value of *Package* is used + instead." + :value nil + :buffer buffer) + (unless (hemlock-bound-p 'buffer-input-mark :buffer buffer) + (defhvar "Buffer Input Mark" + "Mark used for Eval Mode input." + :buffer buffer + :value (copy-mark point :right-inserting)) + (defhvar "Eval Output Stream" + "Output stream used for Eval Mode output in this buffer." + :buffer buffer + :value (make-hemlock-output-stream point)) + (defhvar "Interactive History" + "A ring of the regions input to an interactive mode (Eval or Typescript)." + :buffer buffer + :value (make-ring (value interactive-history-length))) + (defhvar "Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (defhvar "Searching Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0)) + (let ((*standard-output* + (variable-value 'eval-output-stream :buffer buffer))) + (fresh-line) + (princ (if (functionp *prompt*) + (funcall *prompt*) + *prompt*))) + (move-mark (variable-value 'buffer-input-mark :buffer buffer) point))) + +(defmode "Eval" :major-p nil :setup-function #'setup-eval-mode) + +(defun eval-mode-lisp-mode-hook (buffer on) + "Turn on Lisp mode when we go into Eval Mode." + (when on + (setf (buffer-major-mode buffer) "Lisp"))) +;;; +(add-hook eval-mode-hook 'eval-mode-lisp-mode-hook) + +(defhvar "Editor Definition Info" + "When this is non-nil, the editor Lisp is used to determine definition + editing information; otherwise, the slave Lisp is used." + :value t + :mode "Eval") + + +(defvar *selected-eval-buffer* nil) + +(defcommand "Select Eval Buffer" (p) + "Goto buffer in \"Eval\" mode, creating one if necessary." + "Goto buffer in \"Eval\" mode, creating one if necessary." + (declare (ignore p)) + (unless *selected-eval-buffer* + (when (getstring "Eval" *buffer-names*) + (editor-error "There is already a buffer named \"Eval\"!")) + (setf *selected-eval-buffer* + (make-buffer "Eval" + :delete-hook + (list #'(lambda (buf) + (declare (ignore buf)) + (setf *selected-eval-buffer* nil))))) + (setf (buffer-minor-mode *selected-eval-buffer* "Eval") t)) + (change-to-buffer *selected-eval-buffer*)) + + +(defvar lispbuf-eof '(nil)) + +(defhvar "Unwedge Interactive Input Confirm" + "When set (the default), trying to confirm interactive input when the + point is not after the input mark causes Hemlock to ask the user if he + needs to be unwedged. When not set, an editor error is signaled + informing the user that the point is before the input mark." + :value t) + +(defun unwedge-eval-buffer () + (abort-eval-input-command nil)) + +(defhvar "Unwedge Interactive Input Fun" + "Function to call when input is confirmed, but the point is not past the + input mark." + :value #'unwedge-eval-buffer + :mode "Eval") + +(defhvar "Unwedge Interactive Input String" + "String to add to \"Point not past input mark. \" explaining what will + happen if the the user chooses to be unwedged." + :value "Prompt again at the end of the buffer? " + :mode "Eval") + +(defcommand "Confirm Eval Input" (p) + "Evaluate Eval Mode input between point and last prompt." + "Evaluate Eval Mode input between point and last prompt." + (declare (ignore p)) + (let ((input-region (get-interactive-input))) + (when input-region + (let* ((output (value eval-output-stream)) + (*standard-output* output) + (*error-output* output) + (*trace-output* output)) + (fresh-line) + (in-lisp + ;; Copy the region to keep the output and input streams from interacting + ;; since input-region is made of permanent marks into the buffer. + (with-input-from-region (stream (copy-region input-region)) + (loop + (let ((form (read stream nil lispbuf-eof))) + (when (eq form lispbuf-eof) + ;; Move the buffer's input mark to the end of the buffer. + (move-mark (region-start input-region) + (region-end input-region)) + (return)) + (setq +++ ++ ++ + + - - form) + (let ((this-eval (multiple-value-list (eval form)))) + (fresh-line) + (dolist (x this-eval) (prin1 x) (terpri)) + (princ (if (functionp *prompt*) + (funcall *prompt*) + *prompt*)) + (setq /// // // / / this-eval) + (setq *** ** ** * * (car this-eval))))))))))) + +(defcommand "Abort Eval Input" (p) + "Move to the end of the buffer and prompt." + "Move to the end of the buffer and prompt." + (declare (ignore p)) + (let ((point (current-point))) + (buffer-end point) + (insert-character point #\newline) + (insert-string point "Aborted.") + (insert-character point #\newline) + (insert-string point + (if (functionp *prompt*) + (funcall *prompt*) + *prompt*)) + (move-mark (value buffer-input-mark) point))) + + + +;;;; General interactive commands used in eval and typescript buffers. + +(defun get-interactive-input () + "Tries to return a region. When the point is not past the input mark, and + the user has \"Unwedge Interactive Input Confirm\" set, the buffer is + optionally fixed up, and nil is returned. Otherwise, an editor error is + signalled. When a region is returned, the start is the current buffer's + input mark, and the end is the current point moved to the end of the buffer." + (let ((point (current-point)) + (mark (value buffer-input-mark))) + (cond + ((mark>= point mark) + (buffer-end point) + (let* ((input-region (region mark point)) + (string (region-to-string input-region)) + (ring (value interactive-history))) + (when (and (or (zerop (ring-length ring)) + (string/= string (region-to-string (ring-ref ring 0)))) + (> (length string) (value minimum-interactive-input-length))) + (ring-push (copy-region input-region) ring)) + input-region)) + ((value unwedge-interactive-input-confirm) + (beep) + (when (prompt-for-y-or-n + :prompt (concatenate 'simple-string + "Point not past input mark. " + (value unwedge-interactive-input-string)) + :must-exist t :default t :default-string "yes") + (funcall (value unwedge-interactive-input-fun)) + (message "Unwedged.")) + nil) + (t + (editor-error "Point not past input mark."))))) + +(defhvar "Interactive History Length" + "This is the length used for the history ring in interactive buffers. + It must be set before turning on the mode." + :value 10) + +(defhvar "Minimum Interactive Input Length" + "When the number of characters in an interactive buffer exceeds this value, + it is pushed onto the interactive history, otherwise it is lost forever." + :value 2) + + +(defvar *previous-input-search-string* "ignore") + +(defvar *previous-input-search-pattern* + ;; Give it a bogus string since you can't give it the empty string. + (new-search-pattern :string-insensitive :forward "ignore")) + +(defun get-previous-input-search-pattern (string) + (if (string= *previous-input-search-string* string) + *previous-input-search-pattern* + (new-search-pattern :string-insensitive :forward + (setf *previous-input-search-string* string) + *previous-input-search-pattern*))) + +(defcommand "Search Previous Interactive Input" (p) + "Search backward through the interactive history using the current input as + a search string. Consecutive invocations repeat the previous search." + "Search backward through the interactive history using the current input as + a search string. Consecutive invocations repeat the previous search." + (declare (ignore p)) + (let* ((mark (value buffer-input-mark)) + (ring (value interactive-history)) + (point (current-point)) + (just-invoked (eq (last-command-type) :searching-interactive-input))) + (when (mark<= point mark) + (editor-error "Point not past input mark.")) + (when (zerop (ring-length ring)) + (editor-error "No previous input in this buffer.")) + (unless just-invoked + (get-previous-input-search-pattern (region-to-string (region mark point)))) + (let ((found-it (find-previous-input ring just-invoked))) + (unless found-it + (editor-error "Couldn't find ~a." *previous-input-search-string*)) + (delete-region (region mark point)) + (insert-region point (ring-ref ring found-it)) + (setf (value searching-interactive-pointer) found-it)) + (setf (last-command-type) :searching-interactive-input))) + +(defun find-previous-input (ring againp) + (let ((ring-length (ring-length ring)) + (base (if againp + (+ (value searching-interactive-pointer) 1) + 0))) + (loop + (when (= base ring-length) + (if againp + (setf base 0) + (return nil))) + (with-mark ((m (region-start (ring-ref ring base)))) + (when (find-pattern m *previous-input-search-pattern*) + (return base))) + (incf base)))) + +(defcommand "Previous Interactive Input" (p) + "Insert the previous input in an interactive mode (Eval or Typescript). + If repeated, keep rotating the history. With prefix argument, rotate + that many times." + "Pop the *interactive-history* at the point." + (let* ((point (current-point)) + (mark (value buffer-input-mark)) + (ring (value interactive-history)) + (length (ring-length ring)) + (p (or p 1))) + (declare (simple-string current)) + (when (or (mark< point mark) (zerop length)) (editor-error)) + (cond + ((eq (last-command-type) :interactive-history) + (let ((base (mod (+ (value interactive-pointer) p) length))) + (delete-region (region mark point)) + (insert-region point (ring-ref ring base)) + (setf (value interactive-pointer) base))) + (t + (let ((base (mod (if (minusp p) p (1- p)) length)) + (region (delete-and-save-region (region mark point)))) + (insert-region point (ring-ref ring base)) + (when (mark/= (region-start region) (region-end region)) + (ring-push region ring) + (incf base)) + (setf (value interactive-pointer) base))))) + (setf (last-command-type) :interactive-history)) + +(defcommand "Next Interactive Input" (p) + "Rotate the interactive history backwards. The region is left around the + inserted text. With prefix argument, rotate that many times." + "Call previous-interactive-input-command with negated arg." + (previous-interactive-input-command (- (or p 1)))) + +(defcommand "Kill Interactive Input" (p) + "Kill any input to an interactive mode (Eval or Typescript)." + "Kill any input to an interactive mode (Eval or Typescript)." + (declare (ignore p)) + (let ((point (buffer-point (current-buffer))) + (mark (value buffer-input-mark))) + (when (mark< point mark) (editor-error)) + (kill-region (region mark point) :kill-backward))) + +(defcommand "Interactive Beginning of Line" (p) + "If on line with current prompt, go to after it, otherwise do what + \"Beginning of Line\" always does." + "Go to after prompt when on prompt line." + (let ((mark (value buffer-input-mark)) + (point (current-point))) + (if (and (same-line-p point mark) (or (not p) (= p 1))) + (move-mark point mark) + (beginning-of-line-command p)))) + +(defcommand "Reenter Interactive Input" (p) + "Copies the form to the left of point to be after the interactive buffer's + input mark. When the current region is active, it is copied instead." + "Copies the form to the left of point to be after the interactive buffer's + input mark. When the current region is active, it is copied instead." + (declare (ignore p)) + (unless (hemlock-bound-p 'buffer-input-mark) + (editor-error "Not in an interactive buffer.")) + (let ((point (current-point))) + (let ((region (if (region-active-p) + ;; Copy this, so moving point doesn't affect the region. + (copy-region (current-region)) + (with-mark ((start point) + (end point)) + (pre-command-parse-check start) + (unless (form-offset start -1) + (editor-error "Not after complete form.")) + (region (copy-mark start) (copy-mark end)))))) + (buffer-end point) + (push-buffer-mark (copy-mark point)) + (insert-region point region) + (setf (last-command-type) :ephemerally-active)))) + + + +;;; Other stuff. + +(defmode "Editor") + +(defcommand "Editor Mode" (p) + "Turn on \"Editor\" mode in the current buffer. If it is already on, turn it + off. When in editor mode, most lisp compilation and evaluation commands + manipulate the editor process instead of the current eval server." + "Toggle \"Editor\" mode in the current buffer." + (declare (ignore p)) + (setf (buffer-minor-mode (current-buffer) "Editor") + (not (buffer-minor-mode (current-buffer) "Editor")))) + +(define-file-option "Editor" (buffer value) + (declare (ignore value)) + (setf (buffer-minor-mode buffer "Editor") t)) + +(defhvar "Editor Definition Info" + "When this is non-nil, the editor Lisp is used to determine definition + editing information; otherwise, the slave Lisp is used." + :value t + :mode "Editor") + +(defcommand "Editor Compile Defun" (p) + "Compiles the current or next top-level form in the editor Lisp. + First the form is evaluated, then the result of this evaluation + is passed to compile. If the current region is active, this + compiles the region." + "Evaluates the current or next top-level form in the editor Lisp." + (declare (ignore p)) + (if (region-active-p) + (editor-compile-region (current-region)) + (editor-compile-region (defun-region (current-point)) t))) + +(defcommand "Editor Compile Region" (p) + "Compiles lisp forms between the point and the mark in the editor Lisp." + "Compiles lisp forms between the point and the mark in the editor Lisp." + (declare (ignore p)) + (editor-compile-region (current-region))) + +(defun defun-region (mark) + "This returns a region around the current or next defun with respect to mark. + Mark is not used to form the region. If there is no appropriate top level + form, this signals an editor-error. This calls PRE-COMMAND-PARSE-CHECK." + (with-mark ((start mark) + (end mark)) + (pre-command-parse-check start) + (cond ((not (mark-top-level-form start end)) + (editor-error "No current or next top level form.")) + (t (region start end))))) + +(defun editor-compile-region (region &optional quiet) + (unless quiet (message "Compiling region ...")) + (in-lisp + (with-input-from-region (stream region) + (with-pop-up-display (*error-output* :height 19) + (compile-from-stream stream + :defined-from-pathname + (buffer-pathname (current-buffer))))))) + + +(defcommand "Editor Evaluate Defun" (p) + "Evaluates the current or next top-level form in the editor Lisp. + If the current region is active, this evaluates the region." + "Evaluates the current or next top-level form in the editor Lisp." + (declare (ignore p)) + (if (region-active-p) + (editor-evaluate-region-command nil) + (with-input-from-region (stream (defun-region (current-point))) + (clear-echo-area) + (in-lisp + (message "Editor Evaluation returned ~S" + (eval (read stream))))))) + +(defcommand "Editor Evaluate Region" (p) + "Evaluates lisp forms between the point and the mark in the editor Lisp." + "Evaluates lisp forms between the point and the mark in the editor Lisp." + (declare (ignore p)) + (with-input-from-region (stream (current-region)) + (clear-echo-area) + (write-string "Evaluating region in the editor ..." *echo-area-stream*) + (finish-output *echo-area-stream*) + (in-lisp + (do ((object (read stream nil lispbuf-eof) + (read stream nil lispbuf-eof))) + ((eq object lispbuf-eof)) + (eval object))) + (message "Evaluation complete."))) + +(defcommand "Editor Re-evaluate Defvar" (p) + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound. This occurs in the editor Lisp." + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound. This occurs in the editor Lisp." + (declare (ignore p)) + (with-input-from-region (stream (defun-region (current-point))) + (clear-echo-area) + (in-lisp + (let ((form (read stream))) + (unless (eq (car form) 'defvar) (editor-error "Not a DEFVAR.")) + (makunbound (cadr form)) + (message "Evaluation returned ~S" (eval form)))))) + +(defcommand "Editor Macroexpand Expression" (p) + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + (let ((point (buffer-point (current-buffer)))) + (with-mark ((start point)) + (pre-command-parse-check start) + (with-mark ((end start)) + (unless (form-offset end 1) (editor-error)) + (in-lisp + (with-pop-up-display (rts) + (write-string (with-input-from-region (s (region start end)) + (prin1-to-string (funcall (if p + 'macroexpand + 'macroexpand-1) + (read s)))) + rts))))))) + +(defcommand "Editor Evaluate Expression" (p) + "Prompt for an expression to evaluate in the editor Lisp." + "Prompt for an expression to evaluate in the editor Lisp." + (declare (ignore p)) + (in-lisp + (multiple-value-call #'message "=> ~@{~#[~;~S~:;~S, ~]~}" + (eval (prompt-for-expression + :prompt "Editor Eval: " + :help "Expression to evaluate"))))) + +(defcommand "Editor Evaluate Buffer" (p) + "Evaluates the text in the current buffer in the editor Lisp." + "Evaluates the text in the current buffer redirecting *Standard-Output* to + the echo area. This occurs in the editor Lisp. The prefix argument is + ignored." + (declare (ignore p)) + (clear-echo-area) + (write-string "Evaluating buffer in the editor ..." *echo-area-stream*) + (finish-output *echo-area-stream*) + (with-input-from-region (stream (buffer-region (current-buffer))) + (let ((*standard-output* *echo-area-stream*)) + (in-lisp + (do ((object (read stream nil lispbuf-eof) + (read stream nil lispbuf-eof))) + ((eq object lispbuf-eof)) + (eval object)))) + (message "Evaluation complete."))) + + + +;;; With-Output-To-Window -- Internal +;;; +;;; +(defmacro with-output-to-window ((stream name) &body forms) + "With-Output-To-Window (Stream Name) {Form}* + Bind Stream to a stream that writes into the buffer named Name a la + With-Output-To-Mark. The buffer is created if it does not exist already + and a window is created to display the buffer if it is not displayed. + For the duration of the evaluation this window is made the current window." + (let ((nam (gensym)) (buffer (gensym)) (point (gensym)) + (window (gensym)) (old-window (gensym))) + `(let* ((,nam ,name) + (,buffer (or (getstring ,nam *buffer-names*) (make-buffer ,nam))) + (,point (buffer-end (buffer-point ,buffer))) + (,window (or (car (buffer-windows ,buffer)) (make-window ,point))) + (,old-window (current-window))) + (unwind-protect + (progn (setf (current-window) ,window) + (buffer-end ,point) + (with-output-to-mark (,stream ,point) ,@forms)) + (setf (current-window) ,old-window))))) + +(defcommand "Editor Compile File" (p) + "Prompts for file to compile in the editor Lisp. Does not compare source + and binary write dates. Does not check any buffer for that file for + whether the buffer needs to be saved." + "Prompts for file to compile." + (declare (ignore p)) + (let ((pn (prompt-for-file :default + (buffer-default-pathname (current-buffer)) + :prompt "File to compile: "))) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) :error-file nil))))) + +(defcommand "Editor Compile Buffer File" (p) + "Compile the file in the current buffer in the editor Lisp if its associated + binary file (of type .fasl) is older than the source or doesn't exist. When + the binary file is up to date, the user is asked if the source should be + compiled anyway. When the prefix argument is supplied, compile the file + without checking the binary file. When \"Compile Buffer File Confirm\" is + set, this command will ask for confirmation when it otherwise would not." + "Compile the file in the current buffer in the editor Lisp if the fasl file + isn't up to date. When p, always do it." + (let* ((buf (current-buffer)) + (pn (buffer-pathname buf))) + (unless pn (editor-error "Buffer has no associated pathname.")) + (cond ((buffer-modified buf) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Save and compile file ~A? " + (namestring pn)))) + (write-buffer-file buf pn) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) :error-file nil))))) + ((older-or-non-existent-fasl-p pn p) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Compile file ~A? " (namestring pn)))) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) :error-file nil))))) + (t (when (or p + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt + "Fasl file up to date, compile source anyway? ")) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring pn) :error-file nil)))))))) + +(defcommand "Editor Compile Group" (p) + "Compile each file in the current group which needs it in the editor Lisp. + If a file has type LISP and there is a curresponding file with type + FASL which has been written less recently (or it doesn't exit), then + the file is compiled, with error output directed to the \"Compiler Warnings\" + buffer. If a prefix argument is provided, then all the files are compiled. + All modified files are saved beforehand." + "Do a Compile-File in each file in the current group that seems to need it + in the editor Lisp." + (save-all-files-command ()) + (unless *active-file-group* (editor-error "No active file group.")) + (dolist (file *active-file-group*) + (when (string-equal (pathname-type file) "lisp") + (let ((tn (probe-file file))) + (cond ((not tn) + (message "File ~A not found." (namestring file))) + ((older-or-non-existent-fasl-p tn p) + (with-output-to-window (*error-output* "Compiler Warnings") + (in-lisp (compile-file (namestring tn) :error-file nil))))))))) + +(defcommand "List Compile Group" (p) + "List any files that would be compiled by \"Compile Group\". All Modified + files are saved before checking to generate a consistent list." + "Do a Compile-File in each file in the current group that seems to need it." + (declare (ignore p)) + (save-all-files-command ()) + (unless *active-file-group* (editor-error "No active file group.")) + (with-pop-up-display (s) + (write-line "\"Compile Group\" would compile the following files:" s) + (force-output s) + (dolist (file *active-file-group*) + (when (string-equal (pathname-type file) "lisp") + (let ((tn (probe-file file))) + (cond ((not tn) + (format s "File ~A not found.~%" (namestring file))) + ((older-or-non-existent-fasl-p tn) + (write-line (namestring tn) s))) + (force-output s)))))) + +(defhvar "Load Pathname Defaults" + "The default pathname used by the load command.") + +(defcommand "Editor Load File" (p) + "Prompt for a file to load into Editor Lisp." + "Prompt for a file to load into the Editor Lisp." + (declare (ignore p)) + (let ((name (truename (prompt-for-file + :default + (or (value load-pathname-defaults) + (buffer-default-pathname (current-buffer))) + :prompt "Editor file to load: " + :help "The name of the file to load")))) + (setv load-pathname-defaults name) + (in-lisp (load name)))) + + + +;;;; Lisp documentation stuff. + +;;; FUNCTION-TO-DESCRIBE is used in "Editor Describe Function Call" and +;;; "Describe Function Call". +;;; +(defmacro function-to-describe (var error-name) + `(cond ((not (symbolp ,var)) + (,error-name "~S is not a symbol." ,var)) + ((macro-function ,var)) + ((fboundp ,var) + (if (listp (symbol-function ,var)) + ,var + (symbol-function ,var))) + (t + (,error-name "~S is not a function." ,var)))) + +(defcommand "Editor Describe Function Call" (p) + "Describe the most recently typed function name in the editor Lisp." + "Describe the most recently typed function name in the editor Lisp." + (declare (ignore p)) + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (pre-command-parse-check mark1) + (unless (backward-up-list mark1) (editor-error)) + (form-offset (move-mark mark2 (mark-after mark1)) 1) + (with-input-from-region (s (region mark1 mark2)) + (in-lisp + (let* ((sym (read s)) + (fun (function-to-describe sym editor-error))) + (with-pop-up-display (*standard-output*) + (editor-describe-function fun sym))))))) + + +(defcommand "Editor Describe Symbol" (p) + "Describe the previous s-expression if it is a symbol in the editor Lisp." + "Describe the previous s-expression if it is a symbol in the editor Lisp." + (declare (ignore p)) + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (mark-symbol mark1 mark2) + (with-input-from-region (s (region mark1 mark2)) + (in-lisp + (let ((thing (read s))) + (if (symbolp thing) + (with-pop-up-display (*standard-output*) + (describe thing)) + (if (and (consp thing) + (or (eq (car thing) 'quote) + (eq (car thing) 'function)) + (symbolp (cadr thing))) + (with-pop-up-display (*standard-output*) + (describe (cadr thing))) + (editor-error "~S is not a symbol, or 'symbol, or #'symbol." + thing)))))))) + +;;; MARK-SYMBOL moves mark1 and mark2 around the previous or current symbol. +;;; However, if the marks are immediately before the first constituent char +;;; of the symbol name, we use the next symbol since the marks probably +;;; correspond to the point, and Hemlock's cursor display makes it look like +;;; the point is within the symbol name. This also tries to ignore :prefix +;;; characters such as quotes, commas, etc. +;;; +(defun mark-symbol (mark1 mark2) + (pre-command-parse-check mark1) + (with-mark ((tmark1 mark1) + (tmark2 mark1)) + (cond ((and (form-offset tmark1 1) + (form-offset (move-mark tmark2 tmark1) -1) + (or (mark= mark1 tmark2) + (and (find-attribute tmark2 :lisp-syntax + #'(lambda (x) (not (eq x :prefix)))) + (mark= mark1 tmark2)))) + (form-offset mark2 1)) + (t + (form-offset mark1 -1) + (find-attribute mark1 :lisp-syntax + #'(lambda (x) (not (eq x :prefix)))) + (form-offset (move-mark mark2 mark1) 1))))) + + +(defcommand "Editor Describe" (p) + "Call Describe on a Lisp object. + Prompt for an expression which is evaluated to yield the object." + "Prompt for an object to describe." + (declare (ignore p)) + (in-lisp + (let* ((exp (prompt-for-expression + :prompt "Object: " + :help "Expression to evaluate to get object to describe.")) + (obj (eval exp))) + (with-pop-up-display (*standard-output*) + (describe obj))))) + +(defcommand "Filter Region" (p) + "Apply a Lisp function to each line of the region. + An expression is prompted for which should evaluate to a Lisp function + from a string to a string. The function must neither modify its argument + nor modify the return value after it is returned." + "Call prompt for a function, then call Filter-Region with it and the region." + (declare (ignore p)) + (let* ((exp (prompt-for-expression + :prompt "Function: " + :help "Expression to evaluate to get function to use as filter.")) + (fun (in-lisp (eval exp))) + (region (current-region))) + (check-region-query-size region) + (let* ((start (copy-mark (region-start region) :left-inserting)) + (end (copy-mark (region-end region) :left-inserting)) + (region (region start end)) + (undo-region (copy-region region))) + (filter-region fun region) + (make-region-undo :twiddle "Filter Region" region undo-region)))) diff --git a/hemlock/lispeval.lisp b/hemlock/lispeval.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3d27b6652a4ae4b5d92fc835c9f6ad8463ca8970 --- /dev/null +++ b/hemlock/lispeval.lisp @@ -0,0 +1,974 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains code for sending requests to eval servers and the +;;; commands based on that code. +;;; +;;; Written by William Lott and Rob MacLachlan. +;;; + +(in-package "HEMLOCK") + + +;;; The note structure holds everything we need to know about an +;;; operation. Not all operations use all the available fields. +;;; +(defstruct (note (:print-function %print-note)) + (state :unsent) ; :unsent, :pending, :running, :aborted or :dead. + server ; Server-Info for the server this op is on. + context ; Short string describing what this op is doing. + kind ; Either :eval, :compile, or :compile-file + buffer ; Buffer source came from. + region ; Region of request + package ; Package or NIL if none + text ; string containing request + input-file ; File to compile or where stuff was found + net-input-file ; Net version of above. + output-file ; Temporary output file for compiler fasl code. + net-output-file ; Net version of above + output-date ; Temp-file is created before calling compiler, + ; and this is its write date. + lap-file ; The lap file for compiles + error-file ; The file to dump errors into + load ; Load compiled file or not? + (errors 0) ; Count of compiler errors. + (warnings 0)) ; Count of compiler warnings. +;;; +(defun %print-note (note stream d) + (declare (ignore d)) + (format stream "#<Eval-Server-Note for ~A [~A]>" + (note-context note) + (note-state note))) + + + +;;;; Note support routines. + +;;; QUEUE-NOTE -- Internal. +;;; +;;; This queues note for server. SERVER-INFO-NOTES keeps notes in stack order, +;;; not queue order. We also link the note to the server and try to send it +;;; to the server. If we didn't send this note, we tell the user the server +;;; is busy and that we're queuing his note to be sent later. +;;; +(defun queue-note (note server) + (push note (server-info-notes server)) + (setf (note-server note) server) + (maybe-send-next-note server) + (when (eq (note-state note) :unsent) + (message "Server ~A busy, ~A queued." + (server-info-name server) + (note-context note)))) + +;;; MAYBE-SEND-NEXT-NOTE -- Internal. +;;; +;;; Loop over all notes in server. If we see any :pending or :running, then +;;; punt since we can't send one. Otherwise, by the end of the list, we may +;;; have found an :unsent one, and if we did, next will be the last :unsent +;;; note. Remember, SERVER-INFO-NOTES is kept in stack order not queue order. +;;; +(defun maybe-send-next-note (server) + (let ((busy nil) + (next nil)) + (dolist (note (server-info-notes server)) + (ecase (note-state note) + ((:pending :running) + (setf busy t) + (return)) + (:unsent + (setf next note)) + (:aborted :dead))) + (when (and (not busy) next) + (send-note next)))) + +(defun send-note (note) + (let* ((remote (wire:make-remote-object note)) + (server (note-server note)) + (ts (server-info-slave-info server)) + (bg (server-info-background-info server)) + (wire (server-info-wire server))) + (setf (note-state note) :pending) + (message "Sending ~A." (note-context note)) + (case (note-kind note) + (:eval + (wire:remote wire + (server-eval-text remote + (note-package note) + (note-text note) + (and ts (ts-data-stream ts))))) + (:compile + (wire:remote wire + (server-compile-text remote + (note-package note) + (note-text note) + (note-input-file note) + (and ts (ts-data-stream ts)) + (and bg (ts-data-stream bg))))) + (:compile-file + (macrolet ((frob (x) + `(if (pathnamep ,x) + (namestring ,x) + ,x))) + (wire:remote wire + (server-compile-file remote + (note-package note) + (frob (or (note-net-input-file note) + (note-input-file note))) + (frob (or (note-net-output-file note) + (note-output-file note))) + (frob (note-error-file note)) + (frob (note-lap-file note)) + (note-load note) + (and ts (ts-data-stream ts)) + (and bg (ts-data-stream bg)))))) + (t + (error "Unknown note kind ~S" (note-kind note)))) + (wire:wire-force-output wire))) + + +;;;; Server Callbacks. + +(defun operation-started (note) + (let ((note (wire:remote-object-value note))) + (setf (note-state note) :running) + (message "The ~A started." (note-context note))) + (values)) + +(defun eval-form-error (message) + (editor-error message)) + +(defun lisp-error (note start end msg) + (declare (ignore start end)) + (let ((note (wire:remote-object-value note))) + (loud-message "During ~A: ~A" + (note-context note) + msg)) + (values)) + +(defun compiler-error (note start end function severity) + (let* ((note (wire:remote-object-value note)) + (server (note-server note)) + (line (mark-line + (buffer-end-mark + (server-info-background-buffer server)))) + (message (format nil "~:(~A~) in ~A during ~A." + severity + function + (note-context note))) + (error (make-error-info :buffer (note-buffer note) + :message message + :line line))) + (message "~A" message) + (let ((region (case (note-kind note) + (:compile + (note-region note)) + (:compile-file + (buffer-region (note-buffer note))) + (t + (error "Compiler error in ~S?" note))))) + (when region + (let* ((region-end (region-end region)) + (m1 (copy-mark (region-start region) :left-inserting)) + (m2 (copy-mark m1 :left-inserting))) + (when start + (character-offset m1 start) + (when (mark> m1 region-end) + (move-mark m1 region-end))) + (unless (and end (character-offset m2 end)) + (move-mark m2 region-end)) + + (setf (error-info-region error) + (region m1 m2))))) + + (vector-push-extend error (server-info-errors server))) + + (values)) + +(defun eval-text-result (note start end values) + (declare (ignore note start end)) + (message "=> ~{~#[~;~A~:;~A, ~]~}" values) + (values)) + +(defun operation-completed (note abortp) + (let* ((note (wire:remote-object-value note)) + (server (note-server note)) + (file (note-output-file note))) + (wire:forget-remote-translation note) + (setf (note-state note) :dead) + (setf (server-info-notes server) + (delete note (server-info-notes server) + :test #'eq)) + (setf (note-server note) nil) + + (if abortp + (loud-message "The ~A aborted." (note-context note)) + (let ((errors (note-errors note)) + (warnings (note-warnings note))) + (message "The ~A complete.~@[ ~D error~:P~]~@[ ~D warning~:P~]" + (note-context note) + (and (plusp errors) errors) + (and (plusp warnings) warnings)))) + + (let ((region (note-region note))) + (when (regionp region) + (delete-mark (region-start region)) + (delete-mark (region-end region)) + (setf (note-region note) nil))) + + (when (and (eq (note-kind note) + :compile-file) + (not (eq file t)) + file) + (if (> (file-write-date file) + (note-output-date note)) + (let ((new-name (make-pathname :type "fasl" + :defaults (note-input-file note)))) + (rename-file file new-name) + (mach:unix-chmod (namestring new-name) #o644)) + (delete-file file))) + (maybe-send-next-note server)) + (values)) + + +;;;; Stuff to send noise to the server. + +;;; EVAL-FORM-IN-SERVER -- Public. +;;; +(defun eval-form-in-server (server-info form + &optional (package (value current-package))) + "This evals form, a simple-string, in the server for server-info. Package + is the name of the package in which the server reads form, and it defaults + to the value of \"Current Package\". If package is nil, then the slave uses + the value of *package*. If server is busy with other requests, this signals + an editor-error to prevent commands using this from hanging. If the server + dies while evaluating form, then this signals an editor-error. This returns + a list of strings which are the printed representation of all the values + returned by form in the server." + (declare (simple-string form)) + (when (server-info-notes server-info) + (editor-error "Server ~S is currently busy. See \"List Operations\"." + (server-info-name server-info))) + (multiple-value-bind (values error) + (wire:remote-value (server-info-wire server-info) + (server-eval-form package form)) + (when error + (editor-error "The server died before finishing")) + values)) + +;;; EVAL-FORM-IN-SERVER-1 -- Public. +;;; +;;; We use VALUES to squelch the second value of READ-FROM-STRING. +;;; +(defun eval-form-in-server-1 (server-info form + &optional (package (value current-package))) + "This calls EVAL-FORM-IN-SERVER and returns the result of READ'ing from + the first string EVAL-FORM-IN-SERVER returns." + (values (read-from-string + (car (eval-form-in-server server-info form package))))) + +(defun string-eval (string + &key + (server (get-current-eval-server)) + (package (value current-package)) + (context (format nil + "evaluation of ~S" + string))) + "Queues the evaluation of string on an eval server. String is a simple + string. If package is not supplied, the string is eval'ed in the slave's + current package." + (declare (simple-string string)) + (queue-note (make-note :kind :eval + :context context + :package package + :text string) + server) + (values)) + +(defun region-eval (region + &key + (server (get-current-eval-server)) + (package (value current-package)) + (context (region-context region "evaluation"))) + "Queues the evaluation of a region of text on an eval server. If package + is not supplied, the string is eval'ed in the slave's current package." + (let ((region (region (copy-mark (region-start region) :left-inserting) + (copy-mark (region-end region) :left-inserting)))) + (queue-note (make-note :kind :eval + :context context + :region region + :package package + :text (region-to-string region)) + server)) + (values)) + +(defun region-compile (region + &key + (server (get-current-eval-server)) + (package (value current-package))) + "Queues a compilation on an eval server. If package is not supplied, the + string is eval'ed in the slave's current package." + (let* ((region (region (copy-mark (region-start region) :left-inserting) + (copy-mark (region-end region) :left-inserting))) + (buf (line-buffer (mark-line (region-start region)))) + (defined-from (and buf + (namestring (buffer-pathname buf))))) + (queue-note (make-note :kind :compile + :context (region-context region "compilation") + :buffer (and region + (region-start region) + (mark-line (region-start region)) + (line-buffer (mark-line + (region-start region)))) + :region region + :package package + :text (region-to-string region) + :input-file defined-from) + server)) + (values)) + + + +;;;; File compiling noise. + +(defhvar "Remote Compile File" + "When set (the default), this causes slave file compilations to assume the + compilation is occurring on a remote machine. This means the source file + must be world readable. Unsetting this, causes no file accesses to go + through the super root." + :value nil) + +;;; FILE-COMPILE compiles files in a client Lisp. Because of Unix file +;;; protection, one cannot write files over the net unless they are publicly +;;; writeable. To get around this, we create a temporary file that is +;;; publicly writeable for compiler output. This file is renamed to an +;;; ordinary output name if the compiler wrote anything to it, or deleted +;;; otherwise. No temporary file is created when output-file is not t. +;;; + +(defun file-compile (file + &key + buffer + (output-file t) + error-file + lap-file + load + (server (get-current-compile-server)) + (package (value current-package))) + "Compiles file in a client Lisp. When output-file is t, a temporary + output file is used that is publicly writeable in case the client is on + another machine. This file is renamed or deleted after compilation. + Setting \"Remote Compile File\" to nil, inhibits this. If package is not + supplied, the string is eval'ed in the slave's current package." + + (let* ((file (truename file)) ; in case of search-list in pathname. + (namestring (namestring file)) + (note (make-note + :kind :compile-file + :context (format nil "compilation of ~A" namestring) + :buffer buffer + :region nil + :package package + :input-file file + :output-file output-file + :error-file error-file + :lap-file lap-file + :load load))) + + (when (and (value remote-compile-file) + (eq output-file t)) + (multiple-value-bind (net-infile ofile net-ofile date) + (file-compile-temp-file file) + (setf (note-net-input-file note) net-infile) + (setf (note-output-file note) ofile) + (setf (note-net-output-file note) net-ofile) + (setf (note-output-date note) date))) + + (clear-server-errors server + #'(lambda (error) + (eq (error-info-buffer error) + buffer))) + (queue-note note server))) + +;;; FILE-COMPILE-TEMP-FILE creates a a temporary file that is publicly +;;; writable in the directory file is in and with a .fasl type. Four values +;;; are returned -- a pathname suitable for referencing file remotely, the +;;; pathname of the temporary file created, a pathname suitable for referencing +;;; the temporary file remotely, and the write date of the temporary file. +;;; + +(defun file-compile-temp-file (file) + (let ((ofile (loop (let* ((sym (gensym)) + (f (merge-pathnames + (format nil "compile-file-~A.fasl" sym) + file))) + (unless (probe-file f) (return f)))))) + (multiple-value-bind (fd err) + (mach:unix-open (namestring ofile) + mach:o_creat #o666) + (unless fd + (editor-error "Couldn't create compiler temporary output file:~%~ + ~A" (mach:get-unix-error-msg err))) + (mach:unix-fchmod fd #o666) + (mach:unix-close fd)) + (let ((net-ofile (pathname-for-remote-access ofile))) + (values (make-pathname :directory (pathname-directory net-ofile) + :defaults file) + ofile + net-ofile + (file-write-date ofile))))) + +(defun pathname-for-remote-access (file) + (let* ((machine (machine-instance)) + (usable-name (nstring-downcase + (the simple-string + (subseq machine 0 (position #\. machine)))))) + (declare (simple-string machine usable-name)) + (make-pathname :directory (concatenate 'simple-string + "/../" + usable-name + (directory-namestring file)) + :defaults file))) + +;;; REGION-CONTEXT -- internal +;;; +;;; Return a string which describes the code in a region. Thing is the +;;; thing being done to the region. "compilation" or "evaluation"... + +(defun region-context (region thing) + (declare (simple-string thing)) + (pre-command-parse-check (region-start region)) + (let ((start (region-start region))) + (with-mark ((m1 start)) + (unless (start-defun-p m1) + (top-level-offset m1 1)) + (with-mark ((m2 m1)) + (mark-after m2) + (form-offset m2 2) + (format nil + "~A of ~S" + thing + (if (eq (mark-line m1) (mark-line m2)) + (region-to-string (region m1 m2)) + (concatenate 'simple-string + (line-string (mark-line m1)) + "..."))))))) + + +;;;; Commands (Gosh, wow gee!) + +(defcommand "Editor Server Name" (p) + "Echos the editor server's name which can be supplied with the -slave switch + to connect to a designated editor." + "Echos the editor server's name which can be supplied with the -slave switch + to connect to a designated editor." + (declare (ignore p)) + (if *editor-name* + (message "This editor is named ~S." *editor-name*) + (message "This editor is not currently named."))) + +(defcommand "Set Buffer Package" (p) + "Set the package to be used by Lisp evaluation and compilation commands + while in this buffer. When in a slave's interactive buffers, do NOT + set the editor's package variable, but changed the slave's *package*." + "Prompt for a package to make into a buffer-local variable current-package." + (declare (ignore p)) + (let* ((name (string (prompt-for-expression + :prompt "Package name: " + :help "Name of package to associate with this buffer."))) + (buffer (current-buffer)) + (info (value current-eval-server))) + (cond ((and info + (or (eq (server-info-slave-buffer info) buffer) + (eq (server-info-background-buffer info) buffer))) + (wire:remote (server-info-wire info) + (server-set-package name)) + (wire:wire-force-output (server-info-wire info))) + ((eq buffer *selected-eval-buffer*) + (setf *package* (maybe-make-package name))) + (t + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer :value name))) + (when (buffer-modeline-field-p buffer :package) + (dolist (w (buffer-windows buffer)) + (update-modeline-field buffer w :package))))) + +(defcommand "Current Compile Server" (p) + "Echos the current compile server's name. With prefix argument, + shows global one. Does not signal an error or ask about creating a slave." + "Echos the current compile server's name. With prefix argument, + shows global one." + (let ((info (if p + (variable-value 'current-compile-server :global) + (value current-compile-server)))) + (if info + (message "~A" (server-info-name info)) + (message "No ~:[current~;global~] compile server." p)))) + +(defcommand "Set Compile Server" (p) + "Specifies the name of the server used globally for file compilation requests." + "Call select-current-compile-server." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (setf (variable-value 'current-compile-server :global) + (maybe-create-server)))) + +(defcommand "Set Buffer Compile Server" (p) + "Specifies the name of the server used for file compilation requests in + the current buffer." + "Call select-current-compile-server after making a buffer local variable." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (defhvar "Current Compile Server" + "The Server-Info object for the server currently used for compilation requests." + :buffer (current-buffer) + :value (maybe-create-server)))) + +(defcommand "Current Eval Server" (p) + "Echos the current eval server's name. With prefix argument, shows + global one. Does not signal an error or ask about creating a slave." + "Echos the current eval server's name. With prefix argument, shows + global one. Does not signal an error or ask about creating a slave." + (let ((info (if p + (variable-value 'current-eval-server :global) + (value current-eval-server)))) + (if info + (message "~A" (server-info-name info)) + (message "No ~:[current~;global~] eval server." p)))) + +(defcommand "Set Eval Server" (p) + "Specifies the name of the server used globally for evaluation and + compilation requests." + "Call select-current-server." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (setf (variable-value 'current-eval-server :global) + (maybe-create-server)))) + +(defcommand "Set Buffer Eval Server" (p) + "Specifies the name of the server used for evaluation and compilation + requests in the current buffer." + "Call select-current-server after making a buffer local variable." + (declare (ignore p)) + (hlet ((ask-about-old-servers t)) + (defhvar "Current Eval Server" + "The Server-Info for the eval server used in this buffer." + :buffer (current-buffer) + :value (maybe-create-server)))) + +#+ :IGNORETHIS +(defcommand "Connect Registered Eval Server" (p) + "Tries to connect to a registered eval server. Prompts for name." + "Tries to connect to a registered eval server. Prompts for name." + (declare (ignore p)) + (connect-registered-eval-server + (prompt-for-string :prompt "Name to lookup: " + :help "Registered eval server to connect to.") + (prompt-for-string + :prompt "Local server name: " + :help "Editor's name for server and \"Background <name>\" buffer."))) + +(defcommand "Evaluate Defun" (p) + "Evaluates the current or next top-level form. + If the current region is active, then evaluate it." + "Evaluates the current or next top-level form." + (declare (ignore p)) + (if (region-active-p) + (evaluate-region-command nil) + (region-eval (defun-region (current-point))))) + +(defcommand "Re-evaluate Defvar" (p) + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound." + "Evaluate the current or next top-level form if it is a DEFVAR. Treat the + form as if the variable is not bound." + (declare (ignore p)) + (let* ((form (defun-region (current-point))) + (start (region-start form))) + (with-mark ((var-start start) + (var-end start)) + (mark-after var-start) + (form-offset var-start 1) + (form-offset (move-mark var-end var-start) 1) + (let ((exp (concatenate 'simple-string + "(makunbound '" + (region-to-string (region var-start var-end)) + ")"))) + (eval-form-in-server (get-current-eval-server) exp))) + (region-eval form))) + +;;; We use Prin1-To-String in the client so that the expansion gets pretty +;;; printed. Since the expansion can contain unreadable stuff, we can't expect +;;; to be able to read that string back in the editor. We shove the region +;;; at the client Lisp as a string, so it can read from the string with the +;;; right package environment. +;;; + +(defcommand "Macroexpand Expression" (p) + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + "Show the macroexpansion of the current expression in the null environment. + With an argument, use MACROEXPAND instead of MACROEXPAND-1." + (let ((point (current-point))) + (with-mark ((start point)) + (pre-command-parse-check start) + (with-mark ((end start)) + (unless (form-offset end 1) (editor-error)) + (with-pop-up-display (s) + (write-string + (eval-form-in-server-1 + (get-current-eval-server) + (format nil "(prin1-to-string (~S (read-from-string ~S)))" + (if p 'macroexpand 'macroexpand-1) + (region-to-string (region start end)))) + s)))))) + +(defcommand "Evaluate Expression" (p) + "Prompt for an expression to evaluate." + "Prompt for an expression to evaluate." + (declare (ignore p)) + (let ((exp (prompt-for-string + :prompt "Eval: " + :help "Expression to evaluate."))) + (message "=> ~{~#[~;~A~:;~A, ~]~}" + (eval-form-in-server (get-current-eval-server) exp)))) + +(defcommand "Compile Defun" (p) + "Compiles the current or next top-level form. + First the form is evaluated, then the result of this evaluation + is passed to compile. If the current region is active, compile + the region." + "Evaluates the current or next top-level form." + (declare (ignore p)) + (if (region-active-p) + (compile-region-command nil) + (region-compile (defun-region (current-point))))) + +(defcommand "Compile Region" (p) + "Compiles lisp forms between the point and the mark." + "Compiles lisp forms between the point and the mark." + (declare (ignore p)) + (region-compile (current-region))) + +(defcommand "Evaluate Region" (p) + "Evaluates lisp forms between the point and the mark." + "Evaluates lisp forms between the point and the mark." + (declare (ignore p)) + (region-eval (current-region))) + +(defcommand "Evaluate Buffer" (p) + "Evaluates the text in the current buffer." + "Evaluates the text in the current buffer redirecting *Standard-Output* to + the echo area. The prefix argument is ignored." + (declare (ignore p)) + (let ((b (current-buffer))) + (region-eval (buffer-region b) + :context (format nil + "evaluation of buffer ``~A''" + (buffer-name b))))) + +(defcommand "Load File" (p) + "Prompt for a file to load into the current eval server." + "Prompt for a file to load into the current eval server." + (declare (ignore p)) + (let ((name (truename (prompt-for-file + :default + (or (value load-pathname-defaults) + (buffer-default-pathname (current-buffer))) + :prompt "File to load: " + :help "The name of the file to load")))) + (setv load-pathname-defaults name) + (string-eval (format nil "(load ~S)" + (namestring (pathname-for-remote-access name)))))) + +(defcommand "Compile File" (p) + "Prompts for file to compile. Does not compare source and binary write + dates. Does not check any buffer for that file for whether the buffer + needs to be saved." + "Prompts for file to compile." + (declare (ignore p)) + (let ((pn (prompt-for-file :default + (buffer-default-pathname (current-buffer)) + :prompt "File to compile: "))) + (file-compile pn))) + +(defhvar "Compile Buffer File Confirm" + "When set, \"Compile Buffer File\" prompts before doing anything." + :value t) + +(defcommand "Compile Buffer File" (p) + "Compile the file in the current buffer if its associated binary file + (of type .fasl) is older than the source or doesn't exist. When the + binary file is up to date, the user is asked if the source should be + compiled anyway. When the prefix argument is supplied, compile the + file without checking the binary file. When \"Compile Buffer File + Confirm\" is set, this command will ask for confirmation when it + otherwise would not." + "Compile the file in the current buffer if the fasl file isn't up to date. + When p, always do it." + (let* ((buf (current-buffer)) + (pn (buffer-pathname buf))) + (unless pn (editor-error "Buffer has no associated pathname.")) + (cond ((buffer-modified buf) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Save and compile file ~A? " + (namestring pn)))) + (write-buffer-file buf pn) + (file-compile pn :buffer buf))) + ((older-or-non-existent-fasl-p pn p) + (when (or (not (value compile-buffer-file-confirm)) + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt (list "Compile file ~A? " (namestring pn)))) + (file-compile pn :buffer buf))) + ((or p + (prompt-for-y-or-n + :default t :default-string "Y" + :prompt + "Fasl file up to date, compile source anyway? ")) + (file-compile pn :buffer buf))))) + +(defcommand "Compile Group" (p) + "Compile each file in the current group which needs it. + If a file has type LISP and there is a curresponding file with type + FASL which has been written less recently (or it doesn't exit), then + the file is compiled, with error output directed to the \"Compiler Warnings\" + buffer. If a prefix argument is provided, then all the files are compiled. + All modified files are saved beforehand." + "Do a Compile-File in each file in the current group that seems to need it." + (save-all-files-command ()) + (unless *active-file-group* (editor-error "No active file group.")) + (dolist (file *active-file-group*) + (when (string-equal (pathname-type file) "lisp") + (let ((tn (probe-file file))) + (cond ((not tn) + (message "File ~A not found." (namestring file))) + ((older-or-non-existent-fasl-p tn p) + (file-compile tn))))))) + +(defun older-or-non-existent-fasl-p (pathname &optional definitely) + (let ((obj-pn (probe-file (make-pathname :type "fasl" :defaults pathname)))) + (or definitely + (not obj-pn) + (< (file-write-date obj-pn) (file-write-date pathname))))) + + + +;;;; Error hacking stuff. + +(defcommand "Flush Compiler Error Information" (p) + "Flushes all infomation about errors encountered while compiling using the + current server" + "Flushes all infomation about errors encountered while compiling using the + current server" + (declare (ignore p)) + (clear-server-errors (get-current-compile-server t))) + +(defcommand "Next Compiler Error" (p) + "Move to the next compiler error for the current server. If an argument is + given, advance that many errors." + "Move to the next compiler error for the current server. If an argument is + given, advance that many errors." + (let* ((server (get-current-compile-server t)) + (errors (server-info-errors server)) + (fp (fill-pointer errors))) + (when (zerop fp) + (editor-error "There are no compiler errors.")) + (let* ((old-index (server-info-error-index server)) + (new-index (+ (or old-index -1) (or p 1)))) + (when (< new-index 0) + (if old-index + (editor-error "Can't back up ~R, only at the ~:R compiler error." + (- p) (1+ old-index)) + (editor-error "Not even at the first compiler error."))) + (when (>= new-index fp) + (if (= (1+ (or old-index -1)) fp) + (editor-error "No more compiler errors.") + (editor-error "Only ~R remaining compiler error~:P." + (- fp old-index 1)))) + (setf (server-info-error-index server) new-index) + ;; Display the silly error. + (let ((error (aref errors new-index))) + (let ((region (error-info-region error))) + (if region + (let* ((start (region-start region)) + (buffer (line-buffer (mark-line start)))) + (change-to-buffer buffer) + (move-mark (buffer-point buffer) start)) + (message "Hmm, no region for this error."))) + (let* ((line (error-info-line error)) + (buffer (line-buffer line))) + (if (and line (bufferp buffer)) + (let ((mark (mark line 0))) + (unless (buffer-windows buffer) + (let ((window (find-if-not + #'(lambda (window) + (or (eq window (current-window)) + (eq window *echo-area-window*))) + *window-list*))) + (if window + (setf (window-buffer window) buffer) + (make-window mark)))) + (move-mark (buffer-point buffer) mark) + (dolist (window (buffer-windows buffer)) + (move-mark (window-display-start window) mark) + (move-mark (window-point window) mark)) + (delete-mark mark)) + (message "Hmm, no line for this error."))))))) + +(defcommand "Previous Compiler Error" (p) + "Move to the previous compiler error. If an argument is given, move back + that many errors." + "Move to the previous compiler error. If an argument is given, move back + that many errors." + (next-compiler-error-command (- (or p 1)))) + + + +;;;; Operation management commands: + +(defcommand "Abort Operations" (p) + "Abort all operations on current eval server connection." + "Abort all operations on current eval server connection." + (declare (ignore p)) + (let* ((server (get-current-eval-server)) + (wire (server-info-wire server))) + ;; Tell the slave to abort the current operation and to ignore any further + ;; operations. + (dolist (note (server-info-notes server)) + (setf (note-state note) :aborted)) + (ext:send-character-out-of-band (wire:wire-fd wire) #\N) + (wire:remote-value wire (server-accept-operations)) + ;; Synch'ing with server here, causes any operations queued at the socket or + ;; in the server to be ignored, and the last thing evaluated is an + ;; instruction to go on accepting operations. + (wire:wire-force-output wire) + (dolist (note (server-info-notes server)) + (when (eq (note-state note) :pending) + ;; The WIRE:REMOTE-VALUE call should have allowed a handshake to + ;; tell the editor anything :pending was aborted. + (error "Operation ~S is still around after we aborted it?" note))) + ;; Forget anything queued in the editor. + (setf (server-info-notes server) nil))) + +(defcommand "List Operations" (p) + "List all eval server operations which have not yet completed." + "List all eval server operations which have not yet completed." + (declare (ignore p)) + (let ((notes nil)) + ;; Collect all notes, reversing them since they act like a queue but + ;; are not in queue order. + (do-strings (str val *server-names*) + (declare (ignore str)) + (setq notes (nconc notes (reverse (server-info-notes val))))) + (if notes + (with-pop-up-display (s) + (dolist (note notes) + (format s "~@(~8A~) ~A on ~A.~%" + (note-state note) + (note-context note) + (server-info-name (note-server note))))) + (message "No uncompleted operations."))) + (values)) + + +;;;; Describing in the client lisp. + +;;; "Describe Function Call" gets the function name from the current form +;;; as a string. This string is used as the argument to a call to +;;; DESCRIBE-FUNCTION-CALL-AUX which is eval'ed in the client lisp. The +;;; auxiliary function's name is qualified since it is read in the client +;;; Lisp with *package* bound to the buffer's package. The result comes +;;; back as a list of strings, so we read the first string to get out the +;;; string value returned by DESCRIBE-FUNCTION-CALL-AUX in the client Lisp. +;;; +(defcommand "Describe Function Call" (p) + "Describe the current function call." + "Describe the current function call." + (let ((info (value current-eval-server))) + (cond + ((not info) + (message "Describing from the editor Lisp ...") + (editor-describe-function-call-command p)) + (t + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (pre-command-parse-check mark1) + (unless (backward-up-list mark1) (editor-error)) + (form-offset (move-mark mark2 (mark-after mark1)) 1) + (let* ((package (value current-package)) + (package-exists + (eval-form-in-server-1 + info + (format nil + "(if (find-package ~S) t (package-name *package*))" + package) + nil))) + (unless (eq package-exists t) + (message "Using package ~S in ~A since ~ + ~:[there is no current package~;~:*~S does not exist~]." + package-exists (server-info-name info) package)) + (with-pop-up-display (s) + (write-string (eval-form-in-server-1 + info + (format nil "(ed::describe-function-call-aux ~S)" + (region-to-string (region mark1 mark2))) + (if (eq package-exists t) package nil)) + s)))))))) + +;;; DESCRIBE-FUNCTION-CALL-AUX is always evaluated in a client Lisp to some +;;; editor, relying on the fact that the cores have the same functions. String +;;; is the name of a function that is read (in the client Lisp). The result is +;;; a string of all the output from EDITOR-DESCRIBE-FUNCTION. +;;; +(defun describe-function-call-aux (string) + (let* ((sym (read-from-string string)) + (fun (function-to-describe sym error))) + (with-output-to-string (*standard-output*) + (editor-describe-function fun sym)))) + +;;; "Describe Symbol" gets the symbol name and quotes it as the argument to a +;;; call to DESCRIBE-SYMBOL-AUX which is eval'ed in the client lisp. The +;;; auxiliary function's name is qualified since it is read in the client Lisp +;;; with *package* bound to the buffer's package. The result comes back as a +;;; list of strings, so we read the first string to get out the string value +;;; returned by DESCRIBE-SYMBOL-AUX in the client Lisp. +;;; + +(defcommand "Describe Symbol" (p) + "Describe the previous s-expression if it is a symbol." + "Describe the previous s-expression if it is a symbol." + (declare (ignore p)) + (let ((info (value current-eval-server))) + (cond + ((not info) + (message "Describing from the editor Lisp ...") + (editor-describe-symbol-command nil)) + (t + (with-mark ((mark1 (current-point)) + (mark2 (current-point))) + (mark-symbol mark1 mark2) + (with-pop-up-display (s) + (write-string (eval-form-in-server-1 + info + (format nil "(ed::describe-symbol-aux '~A)" + (region-to-string (region mark1 mark2)))) + s))))))) + +(defun describe-symbol-aux (thing) + (with-output-to-string (*standard-output*) + (describe (if (and (consp thing) + (or (eq (car thing) 'quote) + (eq (car thing) 'function)) + (symbolp (cadr thing))) + (cadr thing) + thing)))) diff --git a/hemlock/lispmode.lisp b/hemlock/lispmode.lisp new file mode 100644 index 0000000000000000000000000000000000000000..99978ec810765a142808503b5f4ca803fee304be --- /dev/null +++ b/hemlock/lispmode.lisp @@ -0,0 +1,1453 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Hemlock LISP Mode commands +;;; +;;; Written by Ivan Vazquez and Bill Maddox. +;;; + +(in-package "HEMLOCK") + + + +;;;; #### VARIABLES #### +;;; +;;; These routines are used to define, for standard LISP mode, the start and end +;;; of a block to parse. If these need to be changed for a minor mode that sits +;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the +;;; name of the function to use instead of START-OF-PARSE-BLOCK and +;;; END-OF-PARSE-BLOCK. +;;; + +(defhvar "Parse Start Function" + "Take a mark and move it to the top of a block for paren parsing." + :value 'start-of-parse-block) + +(defhvar "Parse End Function" + "Take a mark and move it to the bottom of a block for paren parsing." + :value 'end-of-parse-block) + + +;;;; #### STRUCTURES #### +;;; +;;; LISP-INFO is the structure used to store the data about the line in its Plist. +;;; +;;; -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether +;;; or not a line's begining and/or ending are quoted. +;;; +;;; -> RANGES-TO-IGNORE is a list of cons cells, each having the form +;;; ( [begining-charpos] [end-charpos] ) each of these cells indicating +;;; a range to ignore. End is exclusive. +;;; +;;; -> NET-OPEN-PARENS, NET-CLOSE-PARENS integers that are the number of +;;; unmatched opening and closing parens that there are on a line. +;;; +;;; -> SIGNATURE-SLOT ... +;;; + +(defstruct (lisp-info (:constructor make-lisp-info ())) + (begins-quoted nil) ; (or t nil) + (ending-quoted nil) ; (or t nil) + (ranges-to-ignore nil) ; (or t nil) + (net-open-parens 0 :type fixnum) + (net-close-parens 0 :type fixnum) + (signature-slot)) + + + +;;;; #### MACROS #### +;;; +;;; The following Macros exist to make it easy to acces the Syntax primitives +;;; without uglifying the code. They were originally written by Maddox. +;;; + +(defmacro scan-char (mark attribute values) + `(find-attribute ,mark ',attribute ,(attr-predicate values))) + +(defmacro rev-scan-char (mark attribute values) + `(reverse-find-attribute ,mark ',attribute ,(attr-predicate values))) + +(defmacro test-char (char attribute values) + `(let ((x (character-attribute ',attribute ,char))) + ,(attr-predicate-aux values))) + +(eval-when (compile load eval) +(defun attr-predicate (values) + (cond ((eq values 't) + '#'plusp) + ((eq values 'nil) + '#'zerop) + (t `#'(lambda (x) ,(attr-predicate-aux values))))) + +(defun attr-predicate-aux (values) + (cond ((eq values t) + '(plusp x)) + ((eq values nil) + '(zerop x)) + ((symbolp values) + `(eq x ',values)) + ((and (listp values) (member (car values) '(and or not))) + (cons (car values) (mapcar #'attr-predicate-aux (cdr values)))) + (t (error "Illegal form in attribute pattern - ~S" values)))) + +); Eval-When (Compile Load Eval) + +;;; +;;; FIND-LISP-CHAR + +(defmacro find-lisp-char (mark) + "Move MARK to next :LISP-SYNTAX character, if one isn't found, return NIL." + `(find-attribute ,mark :lisp-syntax + #'(lambda (x) + (member x '(:open-paren :close-paren :newline :comment + :char-quote :string-quote))))) +;;; +;;; PUSH-RANGE + +(defmacro push-range (new-range info-struct) + "Insert NEW-RANGE into the LISP-INFO-RANGES-TO-IGNORE slot of the INFO-STRUCT." + `(when ,new-range + (setf (lisp-info-ranges-to-ignore ,info-struct) + (cons ,new-range (lisp-info-ranges-to-ignore ,info-struct))))) +;;; +;;; SCAN-DIRECTION + +(defmacro scan-direction (mark forwardp &rest forms) + "Expand to a form that scans either backward or forward according to Forwardp." + (if forwardp + `(scan-char ,mark ,@forms) + `(rev-scan-char ,mark ,@forms))) +;;; +;;; DIRECTION-CHAR + +(defmacro direction-char (mark forwardp) + "Expand to a form that returns either the previous or next character according + to Forwardp." + (if forwardp + `(next-character ,mark) + `(previous-character ,mark))) + +;;; +;;; NEIGHBOR-MARK + +(defmacro neighbor-mark (mark forwardp) + "Expand to a form that moves MARK either backward or forward one character, + depending on FORWARDP." + (if forwardp + `(mark-after ,mark) + `(mark-before ,mark))) + +;;; +;;; NEIGHBOR-LINE + +(defmacro neighbor-line (line forwardp) + "Expand to return the next or previous line, according to Forwardp." + (if forwardp + `(line-next ,line) + `(line-previous ,line))) + + +;;;; #### PARSING FUNCTIONS ### +;;; +;;; PRE-COMMAND-PARSE-CHECK + +(defun pre-command-parse-check (mark &optional (fer-sure-parse nil)) + "Parse the area before the command is actually executed." + (with-mark ((top mark) + (bottom mark)) + (funcall (value parse-start-function) top) + (funcall (value parse-end-function) bottom) + (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse))) + +;;; +;;; PARSE-OVER-BLOCK + +(defun parse-over-block (start-line end-line &optional (fer-sure-parse nil)) + "Parse over an area indicated from END-LINE to START-LINE." + (let ((test-line start-line) + prev-line-info) + + (with-mark ((mark (mark test-line 0))) + + ; Set the pre-begining and post-ending lines to delimit the range + ; of action any command will take. This means set the lisp-info of the + ; lines immediately before and after the block to Nil. + + (when (line-previous start-line) + (setf (getf (line-plist (line-previous start-line)) 'lisp-info) nil)) + (when (line-next end-line) + (setf (getf (line-plist (line-next end-line)) 'lisp-info) nil)) + + (loop + (let ((line-info (getf (line-plist test-line) 'lisp-info))) + + ;; Reparse the line when any of the following are true: + ;; + ;; FER-SURE-PARSE is T + ;; + ;; LINE-INFO or PREV-LINE-INFO are Nil. + ;; + ;; If the line begins quoted and the previous one wasn't + ;; ended quoted. + ;; + ;; The Line's signature slot is invalid (the line has changed). + ;; + + (when (or fer-sure-parse + (not line-info) + (not prev-line-info) + + (not (eq (lisp-info-begins-quoted line-info) + (lisp-info-ending-quoted prev-line-info))) + + (not (eql (line-signature test-line) + (lisp-info-signature-slot line-info)))) + + (move-to-position mark 0 test-line) + + (unless line-info + (setf line-info (make-lisp-info)) + (setf (getf (line-plist test-line) 'lisp-info) line-info)) + + (parse-lisp-line-info mark line-info prev-line-info)) + + (when (eq end-line test-line) + (return nil)) + + (setq prev-line-info line-info) + + (setq test-line (line-next test-line))))))) + + +;;;; #### PARSE BLOCK FINDERS #### +;;; + +(defhvar "Minimum Lines Parsed" + "The minimum number of lines before and after the point parsed by Lisp mode." + :value 50) +(defhvar "Maximum Lines Parsed" + "The maximum number of lines before and after the point parsed by Lisp mode." + :value 500) +(defhvar "Defun Parse Goal" + "Lisp mode parses the region obtained by skipping this many defuns forward + and backward from the point unless this falls outside of the range specified + by \"Minimum Lines Parsed\" and \"Maximum Lines Parsed\"." + :value 2) + + +(macrolet ((frob (step end) + `(let ((min (value minimum-lines-parsed)) + (max (value maximum-lines-parsed)) + (goal (value defun-parse-goal)) + (last-defun nil)) + (declare (fixnum min max goal)) + (do ((line (mark-line mark) (,step line)) + (count 0 (1+ count))) + ((null line) + (,end mark)) + (declare (fixnum count)) + (when (char= (line-character line 0) #\() + (setq last-defun line) + (decf goal) + (when (and (<= goal 0) (>= count min)) + (line-start mark line) + (return))) + (when (> count max) + (line-start mark (or last-defun line)) + (return)))))) + + (defun start-of-parse-block (mark) + (frob line-previous buffer-start)) + + (defun end-of-parse-block (mark) + (frob line-next buffer-end))) + +;;; +;;; START-OF-SEARCH-LINE + +(defun start-of-search-line (line) + "Set LINE to the begining line of the block of text to parse." + (with-mark ((mark (mark line 0))) + (funcall (value 'Parse-Start-Function) mark) + (setq line (mark-line mark)))) + +;;; +;;; END-OF-SEACH-LINE + +(defun end-of-search-line (line) + "Set LINE to the ending line of the block of text to parse." + (with-mark ((mark (mark line 0))) + (funcall (value 'Parse-End-Function) mark) + (setq line (mark-line mark)))) + + +;;; PARSE-LISP-LINE-INFO parses through the line doing the following things: +;;; +;;; Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS. +;;; +;;; Making all areas of the line that should be invalid (comments, +;;; char-quotes, and the inside of strings) and such be in +;;; RANGES-TO-IGNORE. +;;; +;;; Set BEGINS-QUOTED and ENDING-QUOTED +;;; + +(defun parse-lisp-line-info (mark line-info prev-line-info) + "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS, +RANGES-TO-INGORE, and ENDING-QUOTED." + (let ((net-open-parens 0) + (net-close-parens 0)) + (declare (fixnum net-open-parens net-close-parens)) + + ;; Re-set the slots necessary + + (setf (lisp-info-ranges-to-ignore line-info) nil) + + ;; The only way the current line begins quoted is when there + ;; is a previous line and it's ending was quoted. + + (setf (lisp-info-begins-quoted line-info) + (and prev-line-info + (lisp-info-ending-quoted prev-line-info))) + + (if (lisp-info-begins-quoted line-info) + (deal-with-string-quote mark line-info) + (setf (lisp-info-ending-quoted line-info) nil)) + + (unless (lisp-info-ending-quoted line-info) + (loop + (find-lisp-char mark) + (ecase (character-attribute :lisp-syntax (next-character mark)) + + (:open-paren + (setq net-open-parens (1+ net-open-parens)) + (mark-after mark)) + + (:close-paren + (if (zerop net-open-parens) + (setq net-close-parens (1+ net-close-parens)) + (setq net-open-parens (1- net-open-parens))) + (mark-after mark)) + + (:newline + (setf (lisp-info-ending-quoted line-info) nil) + (return t)) + + (:comment + (push-range (cons (mark-charpos mark) (line-length (mark-line mark))) + line-info) + (setf (lisp-info-ending-quoted line-info) nil) + (return t)) + + (:char-quote + (mark-after mark) + (push-range (cons (mark-charpos mark) (1+ (mark-charpos mark))) + line-info) + (mark-after mark)) + + (:string-quote + (mark-after mark) + (unless (deal-with-string-quote mark line-info) + (setf (lisp-info-ending-quoted line-info) t) + (return t)))))) + + (setf (lisp-info-net-open-parens line-info) net-open-parens) + (setf (lisp-info-net-close-parens line-info) net-close-parens) + (setf (lisp-info-signature-slot line-info) + (line-signature (mark-line mark))))) + +;;;; #### STRING QUOTE UTILITIES #### +;;; +;;; + +;;; +;;; VALID-STRING-QUOTE-P + +(defmacro valid-string-quote-p (mark forwardp) + "Return T if the string-quote indicated by MARK is valid." + (let ((test-mark (gensym))) + `(with-mark ((,test-mark ,mark)) + + ,(unless forwardp ; TEST-MARK should always be right before the + `(mark-before ,test-mark)) ; String-quote to be checked. + + (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote) + + (let ((slash-count 0)) + + (loop + (mark-before ,test-mark) + (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote) + (incf slash-count) + (return t))) + (not (oddp slash-count))))))) + +;;; +;;; FIND-VALID-STRING-QUOTE + +(defmacro find-valid-string-quote (mark &key forwardp (cease-at-eol nil)) + "Expand to a form that will leave MARK before a valid string-quote character, + in either a forward or backward direction, according to FORWARDP. If + CEASE-AT-EOL is T then it will return nil if encountering the EOL before a + valid string-quote." + (let ((e-mark (gensym))) + `(with-mark ((,e-mark ,mark)) + + (loop + (unless (scan-direction ,e-mark ,forwardp :lisp-syntax + ,(if cease-at-eol + `(or :newline :string-quote) + `:string-quote)) + (return nil)) + + ,@(if cease-at-eol + `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax + :newline) + (return nil)))) + + (when (valid-string-quote-p ,e-mark ,forwardp) + (move-mark ,mark ,e-mark) + (return t)) + + (neighbor-mark ,e-mark ,forwardp))))) + +;;; DEAL-WITH-STRING-QUOTE +;;; +;;; Called when a string is begun (i.e. parse hits a #\"). It checks for a +;;; matching quote on the line that MARK points to, and puts the +;;; appropriate area in the RANGES-TO-IGNORE slot and leaves MARK pointing +;;; after this area. The "appropriate area" is from MARK to the end of the +;;; line or the matching string-quote, whichever comes first. + +(defun deal-with-string-quote (mark info-struct) + "Alter the current line's info struct as necessary as due to encountering a +string quote character." + (with-mark ((e-mark mark)) + + (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t) + + ;; If matching quote is on this line then mark the area between + ;; the first quote (MARK) and the matching quote as invalid by + ;; pushing its begining and ending into the IGNORE-RANGE. + + (push-range (cons (mark-charpos mark) (mark-charpos e-mark)) + info-struct) + + (setf (lisp-info-ending-quoted info-struct) nil) + (mark-after e-mark) + (move-mark mark e-mark)) + + ;; If the EOL has been hit before the matching quote then mark + ;; the area from MARK to the EOL as invalid. + + (t + (push-range (cons (mark-charpos mark) (1+ (line-length (mark-line mark)))) + info-struct) + + ;; The Ending is marked as still being quoted. + + (setf (lisp-info-ending-quoted info-struct) t) + (line-end mark) + nil)))) + + +;;;; Character validity checking: + +;;; Find-Ignore-Region -- Internal +;;; +;;; If the character in the specified direction from Mark is in an ignore +;;; region, then return the region and the line that the region is in as +;;; values. If there is no ignore region, then return NIL and the Mark-Line. +;;; If the line is not parsed, or there is no character (because of being at +;;; the buffer beginning or end), then return both values NIL. +;;; +(defun find-ignore-region (mark forwardp) + (declare (fixnum pos)) + (flet ((scan (line pos) + (declare (fixnum pos)) + (let ((info (getf (line-plist line) 'lisp-info))) + (if info + (dolist (range (lisp-info-ranges-to-ignore info) + (values nil line)) + (let ((start (car range)) + (end (cdr range))) + (declare (fixnum start end)) + (when (and (>= pos start) (< pos end)) + (return (values range line))))) + (values nil nil))))) + (let ((pos (mark-charpos mark)) + (line (mark-line mark))) + (declare (fixnum pos)) + (cond (forwardp (scan line pos)) + ((> pos 0) (scan line (1- pos))) + (t + (let ((prev (line-previous line))) + (if prev + (scan prev (line-length prev)) + (values nil nil)))))))) + + +;;; Valid-Spot -- Public +;;; +(defun valid-spot (mark forwardp) + "Return true if the character pointed to by Mark is not in a quoted context, + false otherwise. If Forwardp is true, we use the next character, otherwise + we use the previous." + (multiple-value-bind (region line) + (find-ignore-region mark forwardp) + (and line (not region)))) + + +;;; Scan-Direction-Valid -- Internal +;;; +;;; Like scan-direction, but only stop on valid characters. +;;; +(defmacro scan-direction-valid (mark forwardp &rest forms) + (let ((n-mark (gensym)) + (n-line (gensym)) + (n-region (gensym)) + (n-won (gensym))) + `(let ((,n-mark ,mark) (,n-won nil)) + (loop + (multiple-value-bind (,n-region ,n-line) + (find-ignore-region ,n-mark ,forwardp) + (unless ,n-line (return nil)) + (if ,n-region + (move-to-position ,n-mark + ,(if forwardp + `(cdr ,n-region) + `(car ,n-region)) + ,n-line) + (when ,n-won (return t))) + ;; + ;; Peculiar condition when a quoting character terminates a line. + ;; The ignore region is off the end of the line causing %FORM-OFFSET + ;; to infinitely loop. + (when (> (mark-charpos ,n-mark) (line-length ,n-line)) + (line-offset ,n-mark 1 0)) + (unless (scan-direction ,n-mark ,forwardp ,@forms) + (return nil)) + (setq ,n-won t)))))) + + +;;;; #### LIST-OFFSETING #### +;;; +;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built +;;; with the same existing structure, with the altering of one variable. +;;; This one variable being FORWARDP. +;;; +(defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) ) + "Expand to code that will go forward one list either backward or forward, +according to the FORWARDP flag." + (let ((mark (gensym))) + `(let ((paren-count ,extra-parens)) + (declare (fixnum paren-count)) + (with-mark ((,mark ,actual-mark)) + (loop + (scan-direction ,mark ,forwardp :lisp-syntax + (or :close-paren :open-paren :newline)) + (let ((ch (direction-char ,mark ,forwardp))) + (unless ch (return nil)) + (when (valid-spot ,mark ,forwardp) + (case (character-attribute :lisp-syntax ch) + (:close-paren + (decf paren-count) + ,(when forwardp ; When going forward, an unmatching + `(when (<= paren-count 0) ; close-paren means the end of list. + (neighbor-mark ,mark ,forwardp) + (move-mark ,actual-mark ,mark) + (return t)))) + (:open-paren + (incf paren-count) + ,(unless forwardp ; Same as above only end of list + `(when (>= paren-count 0) ; is opening parens. + (neighbor-mark ,mark ,forwardp) + (move-mark ,actual-mark ,mark) + (return t)))) + + (:newline + ;; When a #\Newline is hit, then the matching paren must lie on + ;; some other line so drop down into the multiple line balancing + ;; function: QUEST-FOR-BALANCING-PAREN + ;; If no paren seen yet, keep going. + (cond ((zerop paren-count)) + ((quest-for-balancing-paren ,mark paren-count ,forwardp) + (move-mark ,actual-mark ,mark) + (return t)) + (t + (return nil))))))) + + (neighbor-mark ,mark ,forwardp)))))) + +;;; +;;; QUEST-FOR-BALANCING-PAREN + +(defmacro quest-for-balancing-paren (mark paren-count forwardp) + "Expand to a form that finds the the balancing paren for however many opens or + closes are registered by Paren-Count." + `(let* ((line (mark-line ,mark))) + (loop + (setq line (neighbor-line line ,forwardp)) + (unless line (return nil)) + (let ((line-info (getf (line-plist line) 'lisp-info)) + (unbal-paren ,paren-count)) + (unless line-info (return nil)) + + ,(if forwardp + `(decf ,paren-count (lisp-info-net-close-parens line-info)) + `(incf ,paren-count (lisp-info-net-open-parens line-info))) + + (when ,(if forwardp + `(<= ,paren-count 0) + `(>= ,paren-count 0)) + ,(if forwardp + `(line-start ,mark line) + `(line-end ,mark line)) + (return (goto-correct-paren-char ,mark unbal-paren ,forwardp))) + + ,(if forwardp + `(incf ,paren-count (lisp-info-net-open-parens line-info)) + `(decf ,paren-count (lisp-info-net-close-parens line-info))))))) + + +;;; +;;; GOTO-CORRECT-PAREN-CHAR + +(defmacro goto-correct-paren-char (mark paren-count forwardp) + "Expand to a form that will leave MARK on the correct balancing paren matching + however many are indicated by COUNT." + `(with-mark ((m ,mark)) + (let ((count ,paren-count)) + (loop + (scan-direction m ,forwardp :lisp-syntax + (or :close-paren :open-paren :newline)) + (when (valid-spot m ,forwardp) + (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp)) + (:close-paren + (decf count) + ,(when forwardp + `(when (zerop count) + (neighbor-mark m ,forwardp) + (move-mark ,mark m) + (return t)))) + + (:open-paren + (incf count) + ,(unless forwardp + `(when (zerop count) + (neighbor-mark m ,forwardp) + (move-mark ,mark m) + (return t)))))) + (neighbor-mark m ,forwardp))))) + + +(defun list-offset (mark offset) + (if (plusp offset) + (dotimes (i offset t) + (unless (%list-offset mark t) (return nil))) + (dotimes (i (- offset) t) + (unless (%list-offset mark nil) (return nil))))) + +(defun forward-up-list (mark) + "Moves mark just past the closing paren of the immediately containing list." + (%list-offset mark t :extra-parens 1)) + +(defun backward-up-list (mark) + "Moves mark just before the opening paren of the immediately containing list." + (%list-offset mark nil :extra-parens -1)) + + + +;;;; Top level form location hacks (open parens beginning lines). + +;;; NEIGHBOR-TOP-LEVEL is used only in TOP-LEVEL-OFFSET. +;;; +(eval-when (compile eval) +(defmacro neighbor-top-level (line forwardp) + `(loop + (when (test-char (line-character ,line 0) :lisp-syntax :open-paren) + (return t)) + (setf ,line ,(if forwardp `(line-next ,line) `(line-previous ,line))) + (unless ,line (return nil)))) +) ;eval-when + +(defun top-level-offset (mark offset) + "Go forward or backward offset number of top level forms. Mark is + returned if offset forms exists, otherwise nil." + (declare (fixnum offset)) + (let* ((line (mark-line mark)) + (at-start (test-char (line-character line 0) :lisp-syntax :open-paren))) + (cond ((zerop offset) mark) + ((plusp offset) + (do ((offset (if at-start offset (1- offset)) + (1- offset))) + (nil) + (declare (fixnum offset)) + (unless (neighbor-top-level line t) (return nil)) + (when (zerop offset) (return (line-start mark line))) + (unless (setf line (line-next line)) (return nil)))) + (t + (do ((offset (if (and at-start (start-line-p mark)) + offset + (1+ offset)) + (1+ offset))) + (nil) + (declare (fixnum offset)) + (unless (neighbor-top-level line nil) (return nil)) + (when (zerop offset) (return (line-start mark line))) + (unless (setf line (line-previous line)) (return nil))))))) + + +(defun mark-top-level-form (mark1 mark2) + "Moves mark1 and mark2 to the beginning and end of the current or next defun. + Mark1 one is used as a reference. The marks may be altered even if + unsuccessful. if successful, return mark2, else nil." + (let ((winp (cond ((inside-defun-p mark1) + (cond ((not (top-level-offset mark1 -1)) nil) + ((not (form-offset (move-mark mark2 mark1) 1)) nil) + (t mark2))) + ((start-defun-p mark1) + (form-offset (move-mark mark2 mark1) 1)) + ((and (top-level-offset (move-mark mark2 mark1) -1) + (start-defun-p mark2) + (form-offset mark2 1) + (same-line-p mark1 mark2)) + (form-offset (move-mark mark1 mark2) -1) + mark2) + ((top-level-offset mark1 1) + (form-offset (move-mark mark2 mark1) 1))))) + (when winp + (when (blank-after-p mark2) (line-offset mark2 1 0)) + mark2))) + +(defun inside-defun-p (mark) + "T if the current point is (supposedly) in a top level form." + (with-mark ((m mark)) + (when (top-level-offset m -1) + (form-offset m 1) + (mark> m mark)))) + +(defun start-defun-p (mark) + "Returns t if mark is sitting before an :open-paren at the beginning of a + line." + (and (start-line-p mark) + (test-char (next-character mark) :lisp-syntax :open-paren))) + + + +;;;; #### FORM OFFSETING #### + +(defmacro %form-offset (mark forwardp) + `(with-mark ((m ,mark)) + (when (scan-direction-valid m ,forwardp :lisp-syntax + (or :open-paren :close-paren + :char-quote :string-quote + :constituent)) + (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp)) + (:open-paren + (when ,(if forwardp `(list-offset m 1) `(mark-before m)) + ,(unless forwardp + '(scan-direction m nil :lisp-syntax (not :prefix))) + (move-mark ,mark m) + t)) + (:close-paren + (when ,(if forwardp `(mark-after m) `(list-offset m -1)) + ,(unless forwardp + '(scan-direction m nil :lisp-syntax (not :prefix))) + (move-mark ,mark m) + t)) + ((:constituent :char-quote) + (scan-direction-valid m ,forwardp :lisp-syntax + (not (or :constituent :char-quote))) + ,(if forwardp + `(scan-direction-valid m t :lisp-syntax + (not (or :constituent :char-quote))) + `(scan-direction-valid m nil :lisp-syntax + (not (or :constituent :char-quote + :prefix)))) + (move-mark ,mark m) + t) + (:string-quote + (cond ((valid-spot m ,(not forwardp)) + (neighbor-mark m ,forwardp) + (when (scan-direction-valid m ,forwardp :lisp-syntax + :string-quote) + (neighbor-mark m ,forwardp) + (move-mark ,mark m) + t)) + (t (neighbor-mark m ,forwardp) + (move-mark ,mark m) + t))))))) + + +(defun form-offset (mark offset) + "Move mark offset number of forms, after if positive, before if negative. + Mark is always moved. If there weren't enough forms, returns nil instead of + mark." + (if (plusp offset) + (dotimes (i offset t) + (unless (%form-offset mark t) (return nil))) + (dotimes (i (- offset) t) + (unless (%form-offset mark nil) (return nil))))) + + + +;;; Table of special forms with special indenting requirements. + + +(defhvar "Indent Defanything" + "This is the number of special arguments implicitly assumed to be supplied + in calls to functions whose names begin with \"DEF\". If set to NIL, this + feature is disabled." + :value 2) + +(defvar *special-forms* (make-hash-table :test #'equal)) + +(defun defindent (fname args) + "Define Fname to have Args special arguments. If args is null then remove + any special arguments information." + (check-type fname string) + (let ((fname (string-upcase fname))) + (cond ((null args) (remhash fname *special-forms*)) + (t + (check-type args integer) + (setf (gethash fname *special-forms*) args))))) + + +;;; Hemlock forms. +;;; +(defindent "with-mark" 1) +(defindent "with-random-typeout" 1) +(defindent "with-pop-up-display" 1) +(defindent "defhvar" 1) +(defindent "hlet" 1) +(defindent "defcommand" 2) +(defindent "defattribute" 1) +(defindent "command-case" 1) +(defindent "with-input-from-region" 1) +(defindent "with-output-to-mark" 1) +(defindent "with-output-to-window" 1) +(defindent "do-strings" 1) +(defindent "save-for-undo" 1) +(defindent "do-alpha-chars" 1) +(defindent "do-headers-buffers" 1) +(defindent "do-headers-lines" 1) +(defindent "with-headers-mark" 1) +(defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill. +(defindent "with-writable-buffer" 1) + +;;; Common Lisp forms. +;;; +(defindent "block" 1) +(defindent "case" 1) +(defindent "catch" 1) +(defindent "ccase" 1) +(defindent "compiler-let" 1) +(defindent "ctypecase" 1) +(defindent "defconstant" 1) +(defindent "define-setf-method" 2) +(defindent "defmacro" 2) +(defindent "defparameter" 1) +(defindent "defstruct" 1) +(defindent "deftype" 2) +(defindent "defun" 2) +(defindent "defvar" 1) +(defindent "do" 2) +(defindent "do*" 2) +(defindent "do-all-symbols" 1) +(defindent "do-external-symbols" 1) +(defindent "do-symbols" 1) +(defindent "dolist" 1) +(defindent "dotimes" 1) +(defindent "ecase" 1) +(defindent "etypecase" 1) +(defindent "eval-when" 1) +(defindent "flet" 1) +(defindent "labels" 1) +(defindent "lambda" 1) +(defindent "let" 1) +(defindent "let*" 1) +(defindent "loop" 0) +(defindent "macrolet" 1) +(defindent "multiple-value-bind" 2) +(defindent "multiple-value-call" 1) +(defindent "multiple-value-prog1" 1) +(defindent "multiple-value-setq" 1) +(defindent "prog1" 1) +(defindent "progv" 2) +(defindent "progn" 0) +(defindent "typecase" 1) +(defindent "unless" 1) +(defindent "unwind-protect" 1) +(defindent "when" 1) +(defindent "with-input-from-string" 1) +(defindent "with-open-file" 1) +(defindent "with-open-stream" 1) +(defindent "with-output-to-string" 1) + +;;; Error/condition system forms. +;;; +(defindent "define-condition" 2) +(defindent "handler-bind" 1) +(defindent "handler-case" 1) +(defindent "restart-bind" 1) +(defindent "restart-case" 1) +(defindent "with-simple-restart" 1) +;;; These are for RESTART-CASE branch formatting. +(defindent "store-value" 1) +(defindent "use-value" 1) +(defindent "muffle-warning" 1) +(defindent "abort" 1) +(defindent "continue" 1) + +;;; Xlib forms. +;;; +(defindent "with-gcontext" 1) +(defindent "xlib:with-gcontext" 1) +(defindent "with-state" 1) +(defindent "xlib:with-state" 1) +(defindent "with-display" 1) +(defindent "xlib:with-display" 1) +(defindent "with-event-queue" 1) +(defindent "xlib:with-event-queue" 1) +(defindent "with-server-grabbed" 1) +(defindent "xlib:with-server-grabbed" 1) +(defindent "event-case" 1) +(defindent "xlib:event-case" 1) + +;;; CLOS forms. +;;; +(defindent "with-slots" 1) +(defindent "with-slots*" 2) +(defindent "with-accessors*" 2) +(defindent "defclass" 2) + +;;; System forms. +;;; +(defindent "alien-bind" 1) +(defindent "def-c-record" 1) +(defindent "defrecord" 1) + + + +;;; Compute number of spaces which mark should be indented according to +;;; local context and lisp grinding conventions. + +(defun lisp-indentation (mark) + (with-mark ((m mark) + (temp mark)) + (unless (valid-spot m nil) + (return-from lisp-indentation + (lisp-generic-indentation m))) + (unless (backward-up-list m) + (return-from lisp-indentation 0)) + (mark-after m) + (with-mark ((start m)) + (unless (and (scan-char m :lisp-syntax (not (or :space :prefix :char-quote))) + (test-char (next-character m) :lisp-syntax :constituent)) + (return-from lisp-indentation (mark-column start))) + (with-mark ((fstart m)) + (scan-char m :lisp-syntax (not :constituent)) + (let* ((fname (nstring-upcase (region-to-string (region fstart m)))) + (special-args (or (gethash fname *special-forms*) + (and (> (length fname) 2) + (string= fname "DEF" :end1 3) + (value indent-defanything))))) + (declare (simple-string fname)) + (cond (special-args + (with-mark ((spec m)) + (cond ((and (form-offset spec special-args) + (mark<= spec mark)) + (1+ (mark-column start))) + ((skip-valid-space m) + (mark-column m)) + (t + (+ (mark-column start) 3))))) + ((and (form-offset temp -1) + (or (blank-before-p temp) + (not (same-line-p temp fstart))) + (not (same-line-p temp mark))) + (unless (blank-before-p temp) + (line-start temp) + (find-attribute temp :space #'zerop)) + (mark-column temp)) + ((skip-valid-space m) + (mark-column m)) + (t + (mark-column start)))))))) + +(defun lisp-generic-indentation (mark) + (let* ((line (mark-line mark)) + (prev (do ((line (line-previous line) (line-previous line))) + ((or (null line) (not (blank-line-p line))) line)))) + (cond (prev + (line-start mark prev) + (find-attribute mark :space #'zerop) + (mark-column mark)) + (t 0)))) + +;;; Skip-Valid-Space -- Internal +;;; +;;; Skip over any space on the line Mark is on, stopping at the first valid +;;; non-space character. If there is none on the line, return nil. +;;; +(defun skip-valid-space (mark) + (loop + (scan-char mark :lisp-syntax (not :space)) + (let ((val (character-attribute :lisp-syntax + (next-character mark)))) + (cond ((eq val :newline) (return nil)) + ((valid-spot mark t) (return mark)))) + (mark-after mark))) + + +;;;; LISP Mode commands + +(defcommand "Defindent" (p) + "Define the Lisp indentation for the current function. + The indentation is a non-negative integer which is the number + of special arguments for the form. Examples: 2 for Do, 1 for Dolist. + If a prefix argument is supplied, then delete the indentation information." + "Do a defindent, man!" + (declare (ignore p)) + (with-mark ((m (current-point))) + (pre-command-parse-check m) + (unless (backward-up-list m) (editor-error)) + (mark-after m) + (with-mark ((n m)) + (scan-char n :lisp-syntax (not :constituent)) + (let ((s (region-to-string (region m n)))) + (declare (simple-string s)) + (when (zerop (length s)) (editor-error)) + (if p + (defindent s nil) + (let ((i (prompt-for-integer + :prompt (format nil "Indentation for ~A: " s) + :help "Number of special arguments."))) + (when (minusp i) + (editor-error "Indentation must be non-negative.")) + (defindent s i)))))) + (indent-command ())) + +(defcommand "Beginning of Defun" (p) + "Move the point to the beginning of a top-level form. + with an argument, skips the previous p top-level forms." + "Move the point to the beginning of a top-level form." + (let ((point (current-point)) + (count (or p 1))) + (pre-command-parse-check point) + (if (minusp count) + (end-of-defun-command (- count)) + (unless (top-level-offset point (- count)) + (editor-error))))) + +;;; "End of Defun", with a positive p (the normal case), does something weird. +;;; Get a mark at the beginning of the defun, and then offset it forward one +;;; less top level form than we want. This sets us up to use FORM-OFFSET which +;;; allows us to leave the point immediately after the defun. If we used +;;; TOP-LEVEL-OFFSET one less than p on the mark at the end of the current +;;; defun, point would be left at the beginning of the p+1'st form instead of +;;; at the end of the p'th form. +;;; +(defcommand "End of Defun" (p) + "Move the point to the end of a top-level form. + With an argument, skips the next p top-level forms." + "Move the point to the end of a top-level form." + (let ((point (current-point)) + (count (or p 1))) + (pre-command-parse-check point) + (if (minusp count) + (beginning-of-defun-command (- count)) + (with-mark ((m point) + (dummy point)) + (cond ((not (mark-top-level-form m dummy)) + (editor-error "No current or next top level form.")) + (t + (unless (top-level-offset m (1- count)) + (editor-error "Not enough top level forms.")) + ;; We might be one unparsed for away. + (pre-command-parse-check m) + (unless (form-offset m 1) + (editor-error "Not enough top level forms.")) + (when (blank-after-p m) (line-offset m 1 0)) + (move-mark point m))))))) + +(defcommand "Forward List" (p) + "Skip over the next Lisp list. + With argument, skips the next p lists." + "Skip over the next Lisp list." + (let ((point (current-point)) + (count (or p 1))) + (pre-command-parse-check point) + (unless (list-offset point count) (editor-error)))) + +(defcommand "Backward List" (p) + "Skip over the previous Lisp list. + With argument, skips the previous p lists." + "Skip over the previous Lisp list." + (let ((point (current-point)) + (count (- (or p 1)))) + (pre-command-parse-check point) + (unless (list-offset point count) (editor-error)))) + +(defcommand "Forward Form" (p) + "Skip over the next Form. + With argument, skips the next p Forms." + "Skip over the next Form." + (let ((point (current-point)) + (count (or p 1))) + (pre-command-parse-check point) + (unless (form-offset point count) (editor-error)))) + +(defcommand "Backward Form" (p) + "Skip over the previous Form. + With argument, skips the previous p Forms." + "Skip over the previous Form." + (let ((point (current-point)) + (count (- (or p 1)))) + (pre-command-parse-check point) + (unless (form-offset point count) (editor-error)))) + +(defcommand "Mark Form" (p) + "Set the mark at the end of the next Form. + With a positive argument, set the mark after the following p + Forms. With a negative argument, set the mark before + the preceding -p Forms." + "Set the mark at the end of the next Form." + (with-mark ((m (current-point))) + (pre-command-parse-check m) + (let ((count (or p 1)) + (mark (push-buffer-mark (copy-mark m) t))) + (if (form-offset m count) + (move-mark mark m) + (editor-error))))) + +(defcommand "Mark Defun" (p) + "Puts the region around the next or containing top-level form. + The point is left before the form and the mark is placed immediately + after it." + "Puts the region around the next or containing top-level form." + (declare (ignore p)) + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((start point) + (end point)) + (cond ((not (mark-top-level-form start end)) + (editor-error "No current or next top level form.")) + (t + (move-mark point start) + (move-mark (push-buffer-mark (copy-mark point) t) end)))))) + +(defcommand "Forward Kill Form" (p) + "Kill the next Form. + With a positive argument, kills the next p Forms. + Kills backward with a negative argument." + "Kill the next Form." + (with-mark ((m1 (current-point)) + (m2 (current-point))) + (pre-command-parse-check m1) + (let ((count (or p 1))) + (unless (form-offset m1 count) (editor-error)) + (if (minusp count) + (kill-region (region m1 m2) :kill-backward) + (kill-region (region m2 m1) :kill-forward))))) + +(defcommand "Backward Kill Form" (p) + "Kill the previous Form. + With a positive argument, kills the previous p Forms. + Kills forward with a negative argument." + "Kill the previous Form." + (forward-kill-form-command (- (or p 1)))) + +(defcommand "Extract List" (p) + "Extract the current list. + The current list replaces the surrounding list. The entire affected + area is pushed on the kill-ring. With prefix argument, remove that + many surrounding lists." + "Replace the P containing lists with the current one." + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((lstart point :right-inserting) + (lend point)) + (if (eq (character-attribute :lisp-syntax (next-character lstart)) + :open-paren) + (mark-after lend) + (unless (backward-up-list lstart) (editor-error))) + (unless (forward-up-list lend) (editor-error)) + (with-mark ((rstart lstart) + (rend lend)) + (dotimes (i (or p 1)) + (unless (and (forward-up-list rend) (backward-up-list rstart)) + (editor-error))) + (let ((r (copy-region (region lstart lend)))) + (ring-push (delete-and-save-region (region rstart rend)) + *kill-ring*) + (ninsert-region point r) + (move-mark point lstart)))))) + +(defcommand "Transpose Forms" (p) + "Transpose Forms immediately preceding and following the point. + With a zero argument, tranposes the Forms at the point and the mark. + With a positive argument, transposes the Form preceding the point + with the p-th one following it. With a negative argument, transposes the + Form following the point with the p-th one preceding it." + "Transpose Forms immediately preceding and following the point." + (let ((point (current-point)) + (count (or p 1))) + (pre-command-parse-check point) + (if (zerop count) + (let ((mark (current-mark))) + (with-mark ((s1 mark :left-inserting) + (s2 point :left-inserting)) + (scan-char s1 :whitespace nil) + (scan-char s2 :whitespace nil) + (with-mark ((e1 s1 :right-inserting) + (e2 s2 :right-inserting)) + (unless (form-offset e1 1) (editor-error)) + (unless (form-offset e2 1) (editor-error)) + (ninsert-region s1 (delete-and-save-region (region s2 e2))) + (ninsert-region s2 (delete-and-save-region (region s1 e1)))))) + (let ((fcount (if (plusp count) count 1)) + (bcount (if (plusp count) 1 count))) + (with-mark ((s1 point :left-inserting) + (e2 point :right-inserting)) + (dotimes (i bcount) + (unless (form-offset s1 -1) (editor-error))) + (dotimes (i fcount) + (unless (form-offset e2 1) (editor-error))) + (with-mark ((e1 s1 :right-inserting) + (s2 e2 :left-inserting)) + (unless (form-offset e1 1) (editor-error)) + (unless (form-offset s2 -1) (editor-error)) + (ninsert-region s1 (delete-and-save-region (region s2 e2))) + (ninsert-region s2 (delete-and-save-region (region s1 e1))) + (move-mark point s2))))))) + + +(defcommand "Indent Form" (p) + "Indent Lisp code in the next form." + "Indent Lisp code in the next form." + (declare (ignore p)) + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((m point)) + (unless (form-offset m 1) (editor-error)) + (lisp-indent-region (region point m) "Indent Form")))) + +;;; LISP-INDENT-REGION indents a region of Lisp code without doing excessive +;;; redundant computation. We parse the entire region once, then scan through +;;; doing indentation on each line. We forcibly reparse each line that we +;;; indent so that the list operations done to determine indentation of +;;; subsequent lines will work. This is done undoably with save1, save2, +;;; buf-region, and undo-region. +;;; +(defun lisp-indent-region (region &optional (undo-text "Lisp region indenting")) + (check-region-query-size region) + (let ((start (region-start region)) + (end (region-end region))) + (with-mark ((m1 start) + (m2 end)) + (funcall (value parse-start-function) m1) + (funcall (value parse-end-function) m2) + (parse-over-block (mark-line m1) (mark-line m2))) + (let* ((first-line (mark-line start)) + (last-line (mark-line end)) + (prev (line-previous first-line)) + (prev-line-info + (and prev (getf (line-plist prev) 'lisp-info))) + (save1 (line-start (copy-mark start :right-inserting))) + (save2 (line-end (copy-mark end :left-inserting))) + (buf-region (region save1 save2)) + (undo-region (copy-region buf-region))) + (with-mark ((bol start :left-inserting)) + (do ((line first-line (line-next line))) + (nil) + (line-start bol line) + (insert-lisp-indentation bol) + (let ((line-info (getf (line-plist line) 'lisp-info))) + (parse-lisp-line-info bol line-info prev-line-info) + (setq prev-line-info line-info)) + (when (eq line last-line) (return nil)))) + (make-region-undo :twiddle undo-text buf-region undo-region)))) + +;;; INDENT-FOR-LISP is the value of "Indent Function" for "Lisp" mode. +;;; +(defun indent-for-lisp (mark) + (line-start mark) + (pre-command-parse-check mark) + (insert-lisp-indentation mark)) + +(defun insert-lisp-indentation (m) + (delete-horizontal-space m) + (funcall (value indent-with-tabs) m (lisp-indentation m))) + + +(defcommand "Insert ()" (p) + "Insert a pair of parentheses (). + With positive argument, puts parentheses around the next p + Forms. The point is positioned after the open parenthesis." + "Insert a pair of parentheses ()." + (let ((point (current-point)) + (count (or p 0))) + (pre-command-parse-check point) + (cond ((not (minusp count)) + (insert-character point #\() + (with-mark ((tmark point)) + (unless (form-offset tmark count) (editor-error)) + (cond ((mark= tmark point) + (insert-character point #\)) + (mark-before point)) + (t (insert-character tmark #\)))))) + (t (editor-error))))) + + +(defcommand "Move Over )" (p) + "Move past the next close parenthesis, and start a new line. + Any indentation preceding the preceding the parenthesis is deleted, + and the new line is indented." + "Move past the next close parenthesis, and start a new line." + (declare (ignore p)) + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((m point)) + (cond ((scan-char m :lisp-syntax :close-paren) + (delete-horizontal-space m) + (mark-after m) + (move-mark point m) + (indent-new-line-command 1)) + (t (editor-error)))))) + + +(defcommand "Forward Up List" (p) + "Move forward past a one containing )." + "Move forward past a one containing )." + (let ((point (current-point)) + (count (or p 1))) + (pre-command-parse-check point) + (if (minusp count) + (backward-up-list-command (- count)) + (with-mark ((m point)) + (dotimes (i count (move-mark point m)) + (unless (forward-up-list m) (editor-error))))))) + + +(defcommand "Backward Up List" (p) + "Move backward past a one containing (." + "Move backward past a one containing (." + (let ((point (current-point)) + (count (or p 1))) + (pre-command-parse-check point) + (if (minusp count) + (forward-up-list-command (- count)) + (with-mark ((m point)) + (dotimes (i count (move-mark point m)) + (unless (backward-up-list m) (editor-error))))))) + + +(defcommand "Down List" (p) + "Move down a level in list structure. + With argument, moves down p levels." + "Move down a level in list structure." + (let ((point (current-point)) + (count (or p 1))) + (pre-command-parse-check point) + (with-mark ((m point)) + (dotimes (i count (move-mark point m)) + (unless (and (scan-char m :lisp-syntax :open-paren) + (mark-after m)) + (editor-error)))))) + + + +;;;; "Lisp Mode". + +(defcommand "LISP Mode" (p) + "Put current buffer in LISP mode." + "Put current buffer in LISP mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "LISP")) + + +(defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode) + +(defun setup-lisp-mode (buffer) + (unless (hemlock-bound-p 'current-package :buffer buffer) + (defhvar "Current Package" + "The package used for evaluation of Lisp in this buffer." + :buffer buffer + :value "USER"))) + + + +;;;; Matching parenthesis display. + +(defhvar "Paren Pause Period" + "This is how long commands that deal with \"brackets\" shows the cursor at + the matching \"bracket\" for this number of seconds." + :value 0.5) + +(defcommand "Lisp Insert )" (p) + "Inserts a \")\" and briefly positions the cursor at the matching \"(\"." + "Inserts a \")\" and briefly positions the cursor at the matching \"(\"." + (declare (ignore p)) + (let ((point (current-point))) + (insert-character point #\)) + (pre-command-parse-check point) + (when (valid-spot point nil) + (with-mark ((m point)) + (if (list-offset m -1) + (let ((pause (value paren-pause-period)) + (win (current-window))) + (if pause + (unless (show-mark m win pause) + (clear-echo-area) + (message "~A" (line-string (mark-line m)))) + (unless (displayed-p m (current-window)) + (clear-echo-area) + (message "~A" (line-string (mark-line m)))))) + (editor-error)))))) + +;;; Since we use paren highlighting in Lisp mode, we do not want paren +;;; flashing too. +;;; +(defhvar "Paren Pause Period" + "This is how long commands that deal with \"brackets\" shows the cursor at + the matching \"bracket\" for this number of seconds." + :value nil + :mode "Lisp") +;;; +(defhvar "Highlight Open Parens" + "When non-nil, causes open parens to be displayed in a different font when + the cursor is directly to the right of the corresponding close paren." + :value t + :mode "Lisp") + + + +;;;; Some mode variables to coordinate with other stuff. + +(defhvar "Auto Fill Space Indent" + "When non-nil, uses \"Indent New Comment Line\" to break lines instead of + \"New Line\"." + :mode "Lisp" :value t) + +(defhvar "Comment Start" + "String that indicates the start of a comment." + :mode "Lisp" :value ";") + +(defhvar "Comment Begin" + "String that is inserted to begin a comment." + :mode "Lisp" :value "; ") + +(defhvar "Indent Function" + "Indentation function which is invoked by \"Indent\" command. + It must take one argument that is the prefix argument." + :value 'indent-for-lisp + :mode "Lisp") diff --git a/hemlock/morecoms.lisp b/hemlock/morecoms.lisp new file mode 100644 index 0000000000000000000000000000000000000000..8f018c28b0195eb656f8e404f4421c1b61cd894f --- /dev/null +++ b/hemlock/morecoms.lisp @@ -0,0 +1,825 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles and Rob MacLachlan. +;;; +;;; Even more commands... + +(in-package "HEMLOCK") + +(defhvar "Region Query Size" + "A number-of-lines threshold that destructive, undoable region commands + should ask the user about when the indicated region is too big." + :value 30) + +(defun check-region-query-size (region) + "Checks the number of lines in region against \"Region Query Size\" and + asks the user if the region crosses this threshold. If the user responds + negatively, then an editor error is signaled." + (let ((threshold (or (value region-query-size) 0))) + (if (and (plusp threshold) + (>= (count-lines region) threshold) + (not (prompt-for-y-or-n + :prompt "Region size exceeds \"Region Query Size\". Confirm: " + :must-exist t))) + (editor-error)))) + + + +;;;; Casing commands... + +(defcommand "Uppercase Word" (p) + "Uppercase a word at point. + With prefix argument uppercase that many words." + "Uppercase p words at the point." + (filter-words p (current-point) #'string-upcase)) + +(defcommand "Lowercase Word" (p) + "Uppercase a word at point. + With prefix argument uppercase that many words." + "Uppercase p words at the point." + (filter-words p (current-point) #'string-downcase)) + +;;; FILTER-WORDS implements "Uppercase Word" and "Lowercase Word". +;;; +(defun filter-words (p point function) + (let ((arg (or p 1))) + (with-mark ((mark point)) + (if (word-offset (if (minusp arg) mark point) arg) + (filter-region function (region mark point)) + (editor-error "Not enough words."))))) + +;;; "Capitalize Word" is different than uppercasing and lowercasing because +;;; the differences between Hemlock's notion of what a word is and Common +;;; Lisp's notion are too annoying. +;;; +(defcommand "Capitalize Word" (p) + "Lowercase a word capitalizing the first character. With a prefix + argument, capitalize that many words. A negative argument capitalizes + words before the point, but leaves the point where it was." + "Capitalize p words at the point." + (let ((point (current-point)) + (arg (or p 1))) + (with-mark ((start point :left-inserting) + (end point)) + (when (minusp arg) + (unless (word-offset start arg) (editor-error "No previous word."))) + (do ((region (region start end)) + (cnt (abs arg) (1- cnt))) + ((zerop cnt) (move-mark point end)) + (unless (find-attribute start :word-delimiter #'zerop) + (editor-error "No next word.")) + (move-mark end start) + (find-attribute end :word-delimiter) + (loop + (when (mark= start end) + (move-mark point end) + (editor-error "No alphabetic characters in word.")) + (when (alpha-char-p (next-character start)) (return)) + (character-offset start 1)) + (setf (next-character start) (char-upcase (next-character start))) + (mark-after start) + (filter-region #'string-downcase region))))) + +(defcommand "Uppercase Region" (p) + "Uppercase words from point to mark." + "Uppercase words from point to mark." + (declare (ignore p)) + (twiddle-region (current-region) #'string-upcase "Uppercase Region")) + +(defcommand "Lowercase Region" (p) + "Lowercase words from point to mark." + "Lowercase words from point to mark." + (declare (ignore p)) + (twiddle-region (current-region) #'string-downcase "Lowercase Region")) + +;;; TWIDDLE-REGION implements "Uppercase Region" and "Lowercase Region". +;;; +(defun twiddle-region (region function name) + (let* (;; don't delete marks start and end since undo stuff will. + (start (copy-mark (region-start region) :left-inserting)) + (end (copy-mark (region-end region) :left-inserting))) + (let* ((region (region start end)) + (undo-region (copy-region region))) + (check-region-query-size region) + (filter-region function region) + (make-region-undo :twiddle name region undo-region)))) + + + +;;;; More stuff. + +(defcommand "Delete Previous Character Expanding Tabs" (p) + "Delete the previous character. + When deleting a tab pretend it is the equivalent number of spaces. + With prefix argument, do it that many times." + "Delete the P previous characters, expanding tabs into spaces." + (let ((point (current-point)) + (n (or p 1))) + (when (minusp n) + (editor-error "Delete Previous Character Expanding Tabs only accepts ~ + positive arguments.")) + (let ((errorp nil)) + (with-mark ((mark point :left-inserting)) + (dotimes (i n) + (cond ((char= (previous-character mark) #\tab) + (let ((pos (mark-column mark))) + (delete-characters mark -1) + (dotimes (i (- pos (mark-column mark))) + (insert-character mark #\space)) + (mark-before mark))) + ((mark-before mark)) + (t (return))))) + (kill-characters point (- n)) + (when errorp + (editor-error "There were not ~D characters before point." n))))) + + +(defvar *scope-table* + (list (make-string-table :initial-contents + '(("Global" . :global) + ("Buffer" . :buffer) + ("Mode" . :mode))))) + +(defun prompt-for-place (prompt help) + (multiple-value-bind (word val) + (prompt-for-keyword *scope-table* :prompt prompt + :help help :default "Global") + (declare (ignore word)) + (case val + (:buffer + (values :buffer (prompt-for-buffer :help "Buffer to be local to." + :default (current-buffer)))) + (:mode + (values :mode (prompt-for-keyword + (list *mode-names*) + :prompt "Mode: " + :help "Mode to be local to." + :default (buffer-major-mode (current-buffer))))) + (:global :global)))) + +(defcommand "Bind Key" (p) + "Bind a command to a key. + The command, key and place to make the binding are prompted for." + "Prompt for stuff to do a bind-key." + (declare (ignore p)) + (multiple-value-call #'bind-key + (values (prompt-for-keyword + (list *command-names*) + :prompt "Command to bind: " + :help "Name of command to bind to a key.")) + (values (prompt-for-key + :prompt "Bind to: " :must-exist nil + :help "Key to bind command to, confirm to complete.")) + (prompt-for-place "Kind of binding: " + "The kind of binding to make."))) + +(defcommand "Delete Key Binding" (p) + "Delete a key binding. + The key and place to remove the binding are prompted for." + "Prompt for stuff to do a delete-key-binding." + (declare (ignore p)) + (let ((key (prompt-for-key + :prompt "Delete binding: " :must-exist nil + :help "Key to delete binding from."))) + (multiple-value-bind (kind where) + (prompt-for-place "Kind of binding: " + "The kind of binding to make.") + (unless (get-command key kind where) + (editor-error "No such binding: ~S" key)) + (delete-key-binding key kind where)))) + + +(defcommand "Set Variable" (p) + "Prompt for a Hemlock variable and a new value." + "Prompt for a Hemlock variable and a new value." + (declare (ignore p)) + (multiple-value-bind (name var) + (prompt-for-variable + :prompt "Variable: " + :help "The name of a variable to set.") + (declare (ignore name)) + (setf (variable-value var) + (handle-lisp-errors + (eval (prompt-for-expression + :prompt "Value: " + :help "Expression to evaluate for new value.")))))) + +(defcommand "Defhvar" (p) + "Define a hemlock variable in some location. If the named variable exists + currently, its documentation is propagated to the new instance, but this + never prompts for documentation." + "Define a hemlock variable in some location." + (declare (ignore p)) + (let* ((name (nstring-capitalize (prompt-for-variable :must-exist nil))) + (var (string-to-variable name)) + (doc (if (hemlock-bound-p var) + (variable-documentation var) + "")) + (hooks (if (hemlock-bound-p var) (variable-hooks var))) + (val (prompt-for-expression :prompt "Variable value: " + :help "Value for the variable."))) + (multiple-value-bind + (kind where) + (prompt-for-place + "Kind of binding: " + "Whether the variable is global, mode, or buffer specific.") + (if (eq kind :global) + (defhvar name doc :value val :hooks hooks) + (defhvar name doc kind where :value val :hooks hooks))))) + + +(defcommand "List Buffers" (p) + "Show a list of all buffers. + If the buffer is modified then a * is displayed before the name. If there + is an associated file then it's name is displayed last. With prefix + argument, only list modified buffers." + "Display the names of all buffers in a with-random-typeout window." + (with-pop-up-display (s) + (do-strings (n b *buffer-names*) + (declare (simple-string n)) + (unless (or (eq b *echo-area-buffer*) + (assoc b *random-typeout-buffers* :test #'eq)) + (let ((modified (buffer-modified b)) + (buffer-pathname (buffer-pathname b))) + (when (or (not p) modified) + (write-char (if modified #\* #\space) s) + (if buffer-pathname + (format s "~A ~25T~A~:[~68T~A~;~]~%" + (file-namestring buffer-pathname) + (directory-namestring buffer-pathname) + (string= (pathname-to-buffer-name buffer-pathname) n) + n) + (format s "~A~68T~D Line~:P~%" + n (count-lines (buffer-region b)))))))))) + +(defcommand "Select Random Typeout Buffer" (p) + "Select last random typeout buffer." + "Select last random typeout buffer." + (declare (ignore p)) + (if *random-typeout-buffers* + (change-to-buffer (caar *random-typeout-buffers*)) + (editor-error "There are no random typeout buffers."))) + + +(defcommand "Room" (p) + "Display stats on allocated storage." + "Run Room into a With-Random-Typeout window." + (declare (ignore p)) + (with-pop-up-display (*standard-output* :height 19) + (room))) + + +;;; This is used by the :edit-level modeline field which is defined in Main.Lisp. +;;; +(defvar *recursive-edit-count* 0) + +(defun do-recursive-edit () + "Does a recursive edit, wrapping []'s around the modeline of the current + window during its execution. The current window and buffer are saved + beforehand and restored afterward. If they have been deleted by the + time the edit is done then an editor-error is signalled." + (let* ((win (current-window)) + (buf (current-buffer))) + (unwind-protect + (let ((*recursive-edit-count* (1+ *recursive-edit-count*))) + (update-modeline-field *echo-area-buffer* *echo-area-window* + (modeline-field :edit-level)) + (recursive-edit)) + (update-modeline-field *echo-area-buffer* *echo-area-window* + (modeline-field :edit-level)) + (unless (and (memq win *window-list*) (memq buf *buffer-list*)) + (editor-error "Old window or buffer has been deleted.")) + (setf (current-window) win) + (unless (eq (window-buffer win) buf) + (setf (window-buffer win) buf)) + (setf (current-buffer) buf)))) + +(defcommand "Exit Recursive Edit" (p) + "Exit a level of recursive edit. Signals an error when not in a + recursive edit." + "Exit a level of recursive edit. Signals an error when not in a + recursive edit." + (declare (ignore p)) + (unless (in-recursive-edit) (editor-error "Not in a recursive edit!")) + (exit-recursive-edit ())) + +(defcommand "Abort Recursive Edit" (p) + "Abort the current recursive edit. Signals an error when not in a + recursive edit." + "Abort the current recursive edit. Signals an error when not in a + recursive edit." + (declare (ignore p)) + (unless (in-recursive-edit) (editor-error "Not in a recursive edit!")) + (abort-recursive-edit "Recursive edit aborted.")) + + +;;; TRANSPOSE REGIONS uses CURRENT-REGION to signal an error if the current +;;; region is not active and to get start2 and end2 in proper order. Delete1, +;;; delete2, and delete3 are necessary since we are possibly ROTATEF'ing the +;;; locals end1/start1, start1/start2, and end1/end2, and we need to know which +;;; marks to dispose of at the end of all this stuff. When we actually get to +;;; swapping the regions, we must delete both up front if they both are to be +;;; deleted since we don't know what kind of marks are in start1, start2, end1, +;;; and end2, and the marks will be moving around unpredictably as we insert +;;; text at them. We copy point into ipoint for insertion purposes since one +;;; of our four marks is the point. +;;; +(defcommand "Transpose Regions" (p) + "Transpose two regions with endpoints defined by the mark stack and point. + To use: mark start of region1, mark end of region1, mark start of region2, + and place point at end of region2. Invoking this immediately following + one use will put the regions back, but you will have to activate the + current region." + "Transpose two regions with endpoints defined by the mark stack and point." + (declare (ignore p)) + (unless (>= (ring-length (value buffer-mark-ring)) 3) + (editor-error "Need two marked regions to do Transpose Regions.")) + (let* ((region (current-region)) + (end2 (region-end region)) + (start2 (region-start region)) + (delete1 (pop-buffer-mark)) + (end1 (pop-buffer-mark)) + (delete2 end1) + (start1 (pop-buffer-mark)) + (delete3 start1)) + ;;get marks in the right order, to simplify the code that follows + (unless (mark<= start1 end1) (rotatef start1 end1)) + (unless (mark<= start1 start2) + (rotatef start1 start2) + (rotatef end1 end2)) + ;;order now guaranteed: <Buffer Start> start1 end1 start2 end2 <Buffer End> + (unless (mark<= end1 start2) + (editor-error "Can't transpose overlapping regions.")) + (let* ((adjacent-p (mark= end1 start2)) + (region1 (delete-and-save-region (region start1 end1))) + (region2 (unless adjacent-p + (delete-and-save-region (region start2 end2)))) + (point (current-point))) + (with-mark ((ipoint point :left-inserting)) + (let ((save-end2-loc (push-buffer-mark (copy-mark end2)))) + (ninsert-region (move-mark ipoint end2) region1) + (push-buffer-mark (copy-mark ipoint)) + (cond (adjacent-p + (push-buffer-mark (copy-mark start2)) + (move-mark point save-end2-loc)) + (t (push-buffer-mark (copy-mark end1)) + (ninsert-region (move-mark ipoint end1) region2) + (move-mark point ipoint)))))) + (delete-mark delete1) + (delete-mark delete2) + (delete-mark delete3))) + + +(defcommand "Goto Absolute Line" (p) + "Goes to the indicated line, if you counted them starting at the beginning + of the buffer with the number one. If a prefix argument is supplied, that + is the line numbe; otherwise, the user is prompted." + "Go to a user perceived line number." + (let ((p (or p (prompt-for-expression + :prompt "Line number: " + :help "Enter an absolute line number to goto.")))) + (unless (and (integerp p) (plusp p)) + (editor-error "Must supply a positive integer.")) + (let ((point (current-point))) + (with-mark ((m point)) + (unless (line-offset (buffer-start m) (1- p) 0) + (editor-error "Not enough lines in buffer.")) + (move-mark point m))))) + + + +;;;; Mouse Commands. + +(defcommand "Do Nothing" (p) + "Do nothing. + With prefix argument, do it that many times." + "Do nothing p times." + (dotimes (i (or p 1))) + (setf (last-command-type) (last-command-type))) + +(defun maybe-change-window (window) + (unless (eq window (current-window)) + (when (or (eq window *echo-area-window*) + (eq (current-window) *echo-area-window*) + (member window *random-typeout-buffers* + :key #'(lambda (cons) + (hi::random-typeout-stream-window (cdr cons))))) + (supply-generic-pointer-up-function #'lisp::do-nothing) + (editor-error "I'm afraid I can't let you do that Dave.")) + (setf (current-window) window) + (let ((buffer (window-buffer window))) + (unless (eq (current-buffer) buffer) + (setf (current-buffer) buffer))))) + +(defcommand "Top Line to Here" (p) + "Move the top line to the line the mouse is on. + If in the first two columns then scroll continuously until the button is + released." + "Move the top line to the line the mouse is on." + (declare (ignore p)) + (multiple-value-bind (x y window) + (last-key-event-cursorpos) + (unless y (editor-error)) + (cond ((< x 2) + (do ((ch (read-char-no-hang *editor-input*) + (read-char-no-hang *editor-input*))) + (ch) + (scroll-window window -1) + (redisplay) + (editor-finish-output window))) + (t + (scroll-window window (- y)))))) + +(defcommand "Here to Top of Window" (p) + "Move the line the mouse is on to the top of the window. + If in the first two columns then scroll continuously until the button is + released." + "Move the line the mouse is on to the top of the window." + (declare (ignore p)) + (multiple-value-bind (x y window) + (last-key-event-cursorpos) + (unless y (editor-error)) + (cond ((< x 2) + (do ((ch (read-char-no-hang *editor-input*) + (read-char-no-hang *editor-input*))) + (ch) + (scroll-window window 1) + (redisplay) + (editor-finish-output window))) + (t + (scroll-window window y))))) + + +(defvar *generic-pointer-up-fun* nil + "This is the function for the \"Generic Pointer Up\" command that defines + its action. Other commands set this in preparation for this command's + invocation.") +;;; +(defun supply-generic-pointer-up-function (fun) + "This provides the action \"Generic Pointer Up\" command performs." + (check-type fun function) + (setf *generic-pointer-up-fun* fun)) + +(defcommand "Generic Pointer Up" (p) + "Other commands determine this command's action by supplying functions that + this command invokes. The following built-in commands supply the following + generic up actions: + \"Point to Here\" + When the position of the pointer is different than the current + point, the action pushes a buffer mark at point and moves point + to the pointer's position. + \"Bufed Goto and Quit\" + The action is a no-op." + "Invoke whatever is on *generic-pointer-up-fun*." + (declare (ignore p)) + (unless *generic-pointer-up-fun* + (editor-error "No commands have supplied a \"Generic Pointer Up\" action.")) + (funcall *generic-pointer-up-fun*)) + + +(defcommand "Point to Here" (p) + "Move the point to the position of the mouse. + If in the modeline, move to the absolute position in the file indicated by + the position within the modeline, pushing the old position on the mark + stack. This supplies a function \"Generic Pointer Up\" invokes if it runs + without any intervening generic pointer up predecessors running. If the + position of the pointer is different than the current point when the user + invokes \"Generic Pointer Up\", then this function pushes a buffer mark at + point and moves point to the pointer's position. This allows the user to + mark off a region with the mouse." + "Move the point to the position of the mouse." + (declare (ignore p)) + (multiple-value-bind (x y window) + (last-key-event-cursorpos) + (unless x (editor-error)) + (maybe-change-window window) + (if y + (let ((m (cursorpos-to-mark x y window))) + (unless m (editor-error)) + (move-mark (current-point) m)) + (let* ((buffer (window-buffer window)) + (region (buffer-region buffer)) + (point (buffer-point buffer))) + (push-buffer-mark (copy-mark point)) + (move-mark point (region-start region)) + (line-offset point (round (* (1- (count-lines region)) x) + (1- (window-width window))))))) + (supply-generic-pointer-up-function #'point-to-here-up-action)) + +(defun point-to-here-up-action () + (multiple-value-bind (x y window) + (last-key-event-cursorpos) + (unless x (editor-error)) + (when y + (maybe-change-window window) + (let ((m (cursorpos-to-mark x y window))) + (unless m (editor-error)) + (when (eq (line-buffer (mark-line (current-point))) + (line-buffer (mark-line m))) + (unless (mark= m (current-point)) + (push-buffer-mark (copy-mark (current-point)) t))) + (move-mark (current-point) m))))) + + +(defcommand "Insert Kill Buffer" (p) + "Move current point to the mouse location and insert the kill buffer." + "Move current point to the mouse location and insert the kill buffer." + (declare (ignore p)) + (multiple-value-bind (x y window) + (last-key-event-cursorpos) + (unless x (editor-error)) + (maybe-change-window window) + (if y + (let ((m (cursorpos-to-mark x y window))) + (unless m (editor-error)) + (move-mark (current-point) m) + (un-kill-command nil)) + (editor-error "Can't insert kill buffer in modeline.")))) + + + +;;;; Page commands & stuff. + +(defvar *goto-page-last-num* 0) +(defvar *goto-page-last-string* "") + +(defcommand "Goto Page" (p) + "Go to an absolute page number (argument). If no argument, then go to + next page. A negative argument moves back that many pages if possible. + If argument is zero, prompt for string and goto page with substring + in title." + "Go to an absolute page number (argument). If no argument, then go to + next page. A negative argument moves back that many pages if possible. + If argument is zero, prompt for string and goto page with substring + in title." + (let ((point (current-point))) + (cond ((not p) + (page-offset point 1)) + ((zerop p) + (let* ((againp (eq (last-command-type) :goto-page-zero)) + (name (prompt-for-string :prompt "Substring of page title: " + :default (if againp + *goto-page-last-string* + *parse-default*))) + (dir (page-directory (current-buffer))) + (i 1)) + (declare (simple-string name)) + (cond ((not againp) + (push-buffer-mark (copy-mark point))) + ((string-equal name *goto-page-last-string*) + (setf dir (nthcdr *goto-page-last-num* dir)) + (setf i (1+ *goto-page-last-num*)))) + (loop + (when (null dir) + (editor-error "No page title contains ~S." name)) + (when (search name (the simple-string (car dir)) + :test #'char-equal) + (goto-page point i) + (setf (last-command-type) :goto-page-zero) + (setf *goto-page-last-num* i) + (setf *goto-page-last-string* name) + (return t)) + (incf i) + (setf dir (cdr dir))))) + ((minusp p) + (page-offset point p)) + (t (goto-page point p))) + (line-start (move-mark (window-display-start (current-window)) point)))) + +(defun goto-page (mark i) + (with-mark ((m mark)) + (buffer-start m) + (unless (page-offset m (1- i)) + (editor-error "No page numbered ~D." i)) + (move-mark mark m))) + + +(defcommand "View Page Directory" (p) + "Print a listing of the first non-blank line after each page mark + in a pop-up window." + "Print a listing of the first non-blank line after each page mark + in a pop-up window." + (declare (ignore p)) + (let ((dir (page-directory (current-buffer)))) + (declare (list dir)) + (with-pop-up-display (s :height (1+ (the fixnum (length dir)))) + (display-page-directory s dir)))) + +(defcommand "Insert Page Directory" (p) + "Insert a listing of the first non-blank line after each page mark at + the beginning of the buffer. A mark is dropped before going to the + beginning of the buffer. If an argument is supplied, insert the page + directory at point." + "Insert a listing of the first non-blank line after each page mark at + the beginning of the buffer." + (declare (ignore p)) + (let ((point (current-point))) + (unless p + (push-buffer-mark (copy-mark point)) + (buffer-start point)) + (push-buffer-mark (copy-mark point)) + (display-page-directory (make-hemlock-output-stream point :full) + (page-directory (current-buffer)))) + (setf (last-command-type) :ephemerally-active)) + +(defun display-page-directory (stream directory) + "This writes the list of strings, directory, to stream, enumerating them + in a field of three characters. The number and string are separated by + two spaces, and the first line contains headings for the numbers and + strings columns." + (write-line "Page First Non-blank Line" stream) + (do ((dir directory (cdr dir)) + (count 1 (1+ count))) + ((null dir)) + (declare (fixnum count)) + (format stream "~3D " count) + (write-line (car dir) stream))) + +(defun page-directory (buffer) + "Return a list of strings where each is the first non-blank line + following a :page-delimiter in buffer." + (with-mark ((m (buffer-point buffer))) + (buffer-start m) + (let ((end-of-buffer (buffer-end-mark buffer)) result) + (loop ;over pages. + (loop ;for first non-blank line. + (cond ((not (blank-after-p m)) + (let* ((str (line-string (mark-line m))) + (len (length str))) + (declare (simple-string str)) + (push (if (and (> len 1) + (= (character-attribute :page-delimiter + (schar str 0)) + 1)) + (subseq str 1) + str) + result)) + (unless (page-offset m 1) + (return-from page-directory (nreverse result))) + (when (mark= m end-of-buffer) + (return-from page-directory (nreverse result))) + (return)) + ((not (line-offset m 1 0)) + (return-from page-directory (nreverse result))) + ((= (character-attribute :page-delimiter (next-character m)) + 1) + (push "" result) + (mark-after m) + (return)))))))) + + +(defcommand "Previous Page" (p) + "Move to the beginning of the current page. + With prefix argument move that many pages." + "Move backward P pages." + (let ((point (current-point))) + (unless (page-offset point (- (or p 1))) + (editor-error "No such page.")) + (line-start (move-mark (window-display-start (current-window)) point)))) + +(defcommand "Next Page" (p) + "Move to the beginning of the next page. + With prefix argument move that many pages." + "Move forward P pages." + (let ((point (current-point))) + (unless (page-offset point (or p 1)) + (editor-error "No such page.")) + (line-start (move-mark (window-display-start (current-window)) point)))) + +(defcommand "Mark Page" (p) + "Put point at beginning, mark at end of current page. + With prefix argument, mark the page that many pages after the current one." + "Mark the P'th page after the current one." + (let ((point (current-point))) + (if p + (unless (page-offset point (1+ p)) (editor-error "No such page.")) + (page-offset point 1)) ;If this loses, we're at buffer-end. + (with-mark ((m point)) + (unless (page-offset point -1) + (editor-error "No such page.")) + (push-buffer-mark (copy-mark m) t) + (line-start (move-mark (window-display-start (current-window)) point))))) + +(defun page-offset (mark n) + "Move mark past n :page-delimiters that are in the zero'th line position. + If a :page-delimiter is the immediately next character after mark in the + appropriate direction, then skip it before starting." + (cond ((plusp n) + (find-attribute mark :page-delimiter #'zerop) + (dotimes (i n mark) + (unless (next-character mark) (return nil)) + (loop + (unless (find-attribute mark :page-delimiter) + (return-from page-offset nil)) + (unless (mark-after mark) + (return (if (= i (1- n)) mark))) + (when (= (mark-charpos mark) 1) (return))))) + (t + (reverse-find-attribute mark :page-delimiter #'zerop) + (prog1 + (dotimes (i (- n) mark) + (unless (previous-character mark) (return nil)) + (loop + (unless (reverse-find-attribute mark :page-delimiter) + (return-from page-offset nil)) + (mark-before mark) + (when (= (mark-charpos mark) 0) (return)))) + (let ((buffer (line-buffer (mark-line mark)))) + (unless (or (not buffer) (mark= mark (buffer-start-mark buffer))) + (mark-after mark))))))) + + + +;;;; Counting some stuff + +(defcommand "Count Lines Page" (p) + "Display number of lines in current page and position within page. + With prefix argument do on entire buffer." + "Count some lines, Man." + (let ((point (current-point))) + (if p + (let ((r (buffer-region (current-buffer)))) + (count-lines-function "Buffer" (region-start r) point (region-end r))) + (with-mark ((m1 point) + (m2 point)) + (unless (and (= (character-attribute :page-delimiter + (previous-character m1)) + 1) + (= (mark-charpos m1) 1)) + (page-offset m1 -1)) + (unless (and (= (character-attribute :page-delimiter + (next-character m2)) + 1) + (= (mark-charpos m2) 0)) + (page-offset m2 1)) + (count-lines-function "Page" m1 point m2))))) + +(defun count-lines-function (msg start mark end) + (let ((before (1- (count-lines (region start mark)))) + (after (count-lines (region mark end)))) + (message "~A: ~D lines, ~D/~D" msg (+ before after) before after))) + +(defcommand "Count Lines" (p) + "Display number of lines in the region." + "Display number of lines in the region." + (declare (ignore p)) + (multiple-value-bind (region activep) (get-count-region) + (message "~:[After point~;Active region~]: ~A lines" + activep (count-lines region)))) + +(defcommand "Count Words" (p) + "Prints in the Echo Area the number of words in the region + between the point and the mark by using word-offset. The + argument is ignored." + "Prints Number of Words in the Region" + (declare (ignore p)) + (multiple-value-bind (region activep) (get-count-region) + (let ((end-mark (region-end region))) + (with-mark ((beg-mark (region-start region))) + (let ((word-count 0)) + (loop + (when (mark>= beg-mark end-mark) + (return)) + (unless (word-offset beg-mark 1) + (return)) + (incf word-count)) + (message "~:[After point~;Active region~]: ~D Word~:P" + activep word-count)))))) + +;;; GET-COUNT-REGION -- Internal Interface. +;;; +;;; Returns the active region or the region between point and end-of-buffer. +;;; As a second value, it returns whether the region was active. +;;; +;;; Some searching commands use this routine. +;;; +(defun get-count-region () + (if (region-active-p) + (values (current-region) t) + (values (region (current-point) (buffer-end-mark (current-buffer))) + nil))) + + + +;;;; Some modes: + +(defcommand "Fundamental Mode" (p) + "Put the current buffer into \"Fundamental\" mode." + "Put the current buffer into \"Fundamental\" mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "Fundamental")) + +(defmode "Text" :major-p t) +(defcommand "Text Mode" (p) + "Put the current buffer into \"Text\" mode." + "Put the current buffer into \"Text\" mode." + (declare (ignore p)) + (setf (buffer-major-mode (current-buffer)) "Text")) diff --git a/hemlock/pop-up-stream.lisp b/hemlock/pop-up-stream.lisp new file mode 100644 index 0000000000000000000000000000000000000000..48b548f242e87344886abe6742f821681d8386ad --- /dev/null +++ b/hemlock/pop-up-stream.lisp @@ -0,0 +1,225 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contatins the stream operations for pop-up-displays. +;;; +;;; Written by Blaine Burks. +;;; + +(in-package "HEMLOCK-INTERNALS") + + + +;;;; Line-buffered Stream Methods. + +(defun random-typeout-line-out (stream char) + (insert-character (random-typeout-stream-mark stream) char) + (when (and (char= char #\newline) + (not (random-typeout-stream-no-prompt stream))) + (funcall (device-random-typeout-line-more + (device-hunk-device + (window-hunk (random-typeout-stream-window stream)))) + stream 1))) + +(defun random-typeout-line-sout (stream string start end) + (declare (ignore start end)) + (insert-string (random-typeout-stream-mark stream) string start end) + (unless (random-typeout-stream-no-prompt stream) + (let ((count (count #\newline string))) + (when count + (funcall (device-random-typeout-line-more + (device-hunk-device + (window-hunk (random-typeout-stream-window stream)))) + stream count))))) + +(defun random-typeout-line-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + ((:force-output :finish-output) + (random-typeout-redisplay (random-typeout-stream-window stream))) + (:charpos + (mark-charpos (random-typeout-stream-mark stream))))) + + +;;; Bitmap line-buffered support. + +;;; UPDATE-BITMAP-LINE-BUFFERED-STREAM is called when anything is written to +;;; a line-buffered-random-typeout-stream on the bitmap. It does a lot of +;;; checking to make sure that strings of characters longer than the width of +;;; the window don't screw us. The code is a little wierd, so a brief +;;; explanation is below. +;;; +;;; The more-mark is how we tell when we will next need to more. Each time +;;; we do a more-prompt, we point the mark at the last visible character in +;;; the random typeout window. That way, when the mark is no longer +;;; DISPLAYED-P, we know it's time to do another more prompt. +;;; +;;; If the buffer-end-mark is DISPLAYED-P, then we return, only redisplaying +;;; if there was at least one newline in the last batch of output. If we +;;; haven't done a more prompt yet (indicated by a value of T for +;;; first-more-p), then since we know the end of the buffer isn't visible, we +;;; need to do a more-prompt. If neither of the first two tests returns T, +;;; then we can only need to do a more-prompt if our more-mark has scrolled +;;; off the top of the screen. If it hasn't, everything is peechy-keen, so +;;; we scroll the screen one line and redisplay. +;;; +(defun update-bitmap-line-buffered-stream (stream newline-count) + (let* ((window (random-typeout-stream-window stream)) + (count 0)) + (when (plusp newline-count) (random-typeout-redisplay window)) + (loop + (cond ((no-text-past-bottom-p window) + (return)) + ((or (random-typeout-stream-first-more-p stream) + (not (displayed-p (random-typeout-stream-more-mark stream) + window))) + (do-bitmap-more-prompt stream) + (return)) + (t + (scroll-window window 1) + (random-typeout-redisplay window))) + (when (= (incf count) newline-count) (return))))) + +;;; NO-TEXT-PAST-BOTTOM-P determines whether there is text left to be displayed +;;; in the random-typeout window. It does this by first making sure there is a +;;; line past the WINDOW-DISPLAY-END of the window. If there is, this line +;;; must be empty, and BUFFER-END-MARK must be on this line. The final test is +;;; that the window-end is displayed within the window. If it is not, then the +;;; last line wraps past the end of the window, and there is text past the +;;; bottom. +;;; +;;; Win-end is bound after the call to DISPLAYED-P because it updates the +;;; window's image moving WINDOW-DISPLAY-END. We want this updated value for +;;; the display end. +;;; +(defun no-text-past-bottom-p (window) + (let* ((window-end (window-display-end window)) + (window-end-displayed-p (displayed-p window-end window))) + (with-mark ((win-end window-end)) + (let ((one-after-end (line-offset win-end 1))) + (if one-after-end + (and (empty-line-p win-end) + (same-line-p win-end (buffer-end-mark (window-buffer window))) + window-end-displayed-p) + window-end-displayed-p))))) + +(defun reset-more-mark (stream) + (let* ((window (random-typeout-stream-window stream)) + (more-mark (random-typeout-stream-more-mark stream)) + (end (window-display-end window))) + (move-mark more-mark end) + (unless (displayed-p end window) (character-offset more-mark -1)))) + +;;; DO-BITMAP-MORE-PROMPT is the function that atually displays the more prompt +;;; and reacts to it. Things are pretty clear. The loop is neccessary because +;;; someone could screw us by never outputting newlines. Improbable, but +;;; possible. +;;; +(defun do-bitmap-more-prompt (stream) + (let* ((window (random-typeout-stream-window stream)) + (height (window-height window))) + (setf (random-typeout-stream-first-more-p stream) nil) + (reset-more-mark stream) + (loop + (when (no-text-past-bottom-p window) (return)) + (display-more-prompt stream) + (do ((i 0 (1+ i))) + ((or (= i height) (no-text-past-bottom-p window))) + (scroll-window window 1) + (random-typeout-redisplay window))) + (unless (displayed-p (random-typeout-stream-more-mark stream) window) + (reset-more-mark stream)))) + + +;;; Tty line-buffered support. + +;;; UPDATE-TTY-LINE-BUFFERED-STREAM is called when anything is written to +;;; a line-buffered-random-typeout-stream on the tty. It just makes sure +;;; hemlock doesn't choke on extra-long strings. +;;; +(defun update-tty-line-buffered-stream (stream newline-count) + (let ((window (random-typeout-stream-window stream))) + (when (plusp newline-count) (random-typeout-redisplay window)) + (loop + (when (no-text-past-bottom-p window) (return)) + (display-more-prompt stream) + (scroll-window window (window-height window)) + (random-typeout-redisplay window)))) + + +;;;; Full-buffered Stream Methods. + +(defun random-typeout-full-out (stream char) + (insert-character (random-typeout-stream-mark stream) char)) + +(defun random-typeout-full-sout (stream string start end) + (declare (ignore start end)) + (insert-string (random-typeout-stream-mark stream) string start end)) + +(defun random-typeout-full-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:charpos + (mark-charpos (random-typeout-stream-mark stream))))) + + +;;; Bitmap full-buffered support. + +;;; DO-BITMAP-FULL-MORE and DO-TTY-FULL-MORE scroll through the fresh text in +;;; random typeout buffer. The bitmap function does some checking so that +;;; we don't overshoot the end of the buffer. +;;; +(defun do-bitmap-full-more (stream) + (let* ((window (random-typeout-stream-window stream)) + (buffer (window-buffer window)) + (height (window-height window))) + (with-mark ((end-check (buffer-end-mark buffer))) + (when (and (mark/= (buffer-start-mark buffer) end-check) + (empty-line-p end-check)) + (line-end (line-offset end-check -1))) + (loop + (when (displayed-p end-check window) + (return)) + (display-more-prompt stream) + (do ((i 0 (1+ i))) + ((or (= i height) (displayed-p end-check window))) + (scroll-window window 1) + (random-typeout-redisplay window)))))) + + +;;; Tty full-buffered support. + +(defun do-tty-full-more (stream) + (let* ((window (random-typeout-stream-window stream)) + (buffer (window-buffer window))) + (with-mark ((end-check (buffer-end-mark buffer))) + (when (and (mark/= (buffer-start-mark buffer) end-check) + (empty-line-p end-check)) + (line-end (line-offset end-check -1))) + (loop + (when (displayed-p end-check window) + (return)) + (display-more-prompt stream) + (scroll-window window (window-height window)))))) + + +;;; Proclaim this special so the compiler doesn't warn me. I hate that. +;;; +(proclaim '(special *more-prompt-action*)) + +(defun display-more-prompt (stream) + (unless (random-typeout-stream-no-prompt stream) + (let ((window (random-typeout-stream-window stream)) + (*more-prompt-action* :more)) + (update-modeline-field (window-buffer window) window :more-prompt) + (random-typeout-redisplay window) + (wait-for-more stream) + (let ((*more-prompt-action* :empty)) + (update-modeline-field (window-buffer window) window :more-prompt))))) diff --git a/hemlock/register.lisp b/hemlock/register.lisp new file mode 100644 index 0000000000000000000000000000000000000000..eb49e71ebb2f2fe1bf2821fe9a7863a735ec117f --- /dev/null +++ b/hemlock/register.lisp @@ -0,0 +1,181 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Registers for holding text and positions. +;;; +;;; Written by Dave Touretzky. +;;; Modified by Bill Chiles for Hemlock consistency. +;;; +(in-package 'hemlock) + + + +;;;; Registers implementation. + +;;; Registers are named by characters. Each register refers to a mark or +;;; a cons of a region and the buffer it came from. +;;; +(defvar *registers* (make-hash-table)) + +(defun register-count () + (hash-table-count *registers*)) + +(defun register-value (reg-name) + (gethash reg-name *registers*)) + +(defsetf register-value (reg-name) (new-value) + (let ((name (gensym)) + (value (gensym)) + (old-value (gensym))) + `(let* ((,name ,reg-name) + (,value ,new-value) + (,old-value (gethash ,name *registers*))) + (when (and ,old-value (markp ,old-value)) + (delete-mark ,old-value)) + (setf (gethash ,name *registers*) ,value)))) + +(defun prompt-for-register (&optional (prompt "Register: ") must-exist) + (let ((reg-name (char-upcase (prompt-for-character :prompt prompt)))) + (unless (or (not must-exist) (gethash reg-name *registers*)) + (editor-error "Register ~A is empty." reg-name)) + reg-name)) + + +(defmacro do-registers ((name value &optional sorted) &rest body) + (if sorted + (let ((sorted-regs (gensym)) + (reg (gensym))) + `(let ((,sorted-regs nil)) + (declare (list ,sorted-regs)) + (maphash #'(lambda (,name ,value) + (push (cons ,name ,value) ,sorted-regs)) + *registers*) + (setf ,sorted-regs (sort ,sorted-regs #'char-lessp :key #'car)) + (dolist (,reg ,sorted-regs) + (let ((,name (car ,reg)) + (,value (cdr ,reg))) + ,@body)))) + `(maphash #'(lambda (,name ,value) + ,@body) + *registers*))) + + +;;; Hook to clean things up if a buffer is deleted while registers point to it. +;;; +(defun flush-reg-references-to-deleted-buffer (buffer) + (do-registers (name value) + (declare (ignore name)) + (etypecase value + (mark (when (eq (line-buffer (mark-line value)) buffer) + (free-register name))) + (cons (free-register-value value buffer))))) +;;; +(add-hook delete-buffer-hook 'flush-reg-references-to-deleted-buffer) + + +(defun free-register (name) + (let ((value (register-value name))) + (when value (free-register-value value))) + (remhash name *registers*)) + +(defun free-register-value (value &optional buffer) + (etypecase value + (mark + (when (or (not buffer) (eq (line-buffer (mark-line value)) buffer)) + (delete-mark value))) + (cons + (when (and buffer (eq (cdr value) buffer)) + (setf (cdr value) nil))))) + + + +;;;; Commands. + +;;; These commands all stash marks and regions with marks that point into some +;;; buffer, and they assume that the register values have the same property. +;;; + +(defcommand "Save Position" (p) + "Saves the current location in a register. Prompts for register name." + "Saves the current location in a register. Prompts for register name." + (declare (ignore p)) + (let ((reg-name (prompt-for-register))) + (setf (register-value reg-name) + (copy-mark (current-point) :left-inserting)))) + +(defcommand "Jump to Saved Position" (p) + "Moves the point to a location previously saved in a register." + "Moves the point to a location previously saved in a register." + (declare (ignore p)) + (let* ((reg-name (prompt-for-register "Jump to Register: " t)) + (val (register-value reg-name))) + (unless (markp val) + (editor-error "Register ~A does not hold a location." reg-name)) + (change-to-buffer (line-buffer (mark-line val))) + (move-mark (current-point) val))) + +(defcommand "Kill Register" (p) + "Kill a regist er. Prompts for the name." + "Kill a register. Prompts for the name." + (declare (ignore p)) + (free-register (prompt-for-register "Register to kill: "))) + +(defcommand "List Registers" (p) + "Lists all registers in a pop-up window." + "Lists all registers in a pop-up window." + (declare (ignore p)) + (with-pop-up-display (f :height (* 2 (register-count))) + (do-registers (name val :sorted) + (write-string "Reg " f) + (print-pretty-character name f) + (write-string ": " f) + (etypecase val + (mark + (let* ((line (mark-line val)) + (buff (line-buffer line)) + (len (line-length line))) + (format f "Line ~S, col ~S in buffer ~A~% ~A~:[~;...~]~%" + (count-lines (region (buffer-start-mark buff) val)) + (mark-column val) + (buffer-name buff) + (subseq (line-string line) 0 (min 61 len)) + (> len 60)))) + (cons + (let* ((str (region-to-string (car val))) + (nl (position #\newline str :test #'char=)) + (len (length str)) + (buff (cdr val))) + (declare (simple-string str)) + (format f "Text~@[ from buffer ~A~]~% ~A~:[~;...~]~%" + (if buff (buffer-name buff)) + (subseq str 0 (if nl (min 61 len nl) (min 61 len))) + (> len 60)))))))) + +(defcommand "Put Register" (p) + "Copies a region into a register. Prompts for register name." + "Copies a region into a register. Prompts for register name." + (declare (ignore p)) + (let ((region (current-region))) + ;; Bind the region before prompting in case the region isn't active. + (setf (register-value (prompt-for-register)) + (cons (copy-region region) (current-buffer))))) + +(defcommand "Get Register" (p) + "Copies a region from a register to the current point." + "Copies a region from a register to the current point." + (declare (ignore p)) + (let* ((reg-name (prompt-for-register "Register from which to get text: " t)) + (val (register-value reg-name))) + (unless (and (consp val) (regionp (car val))) + (editor-error "Register ~A does not hold a region." reg-name)) + (let ((point (current-point))) + (push-buffer-mark (copy-mark point)) + (insert-region (current-point) (car val)))) + (setf (last-command-type) :ephemerally-active)) diff --git a/hemlock/ring.lisp b/hemlock/ring.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6dccacb3d03df64e5987a62e420fd4523d594ffd --- /dev/null +++ b/hemlock/ring.lisp @@ -0,0 +1,204 @@ +;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Rob MacLachlan +;;; +;;; This file defines a ring-buffer type and access functions. +;;; +(in-package 'hemlock-internals) +(export '(ring ringp make-ring ring-push ring-pop ring-length ring-ref + rotate-ring)) + + +(defun %print-hring (obj stream depth) + (declare (ignore depth obj)) + (write-string "#<Hemlock Ring>" stream)) + +;;;; The ring data structure: +;;; +;;; An empty ring is indicated by an negative First value. +;;; The Bound is made (1- (- Size)) to make length work. Things are +;;; pushed at high indices first. +;;; +(defstruct (ring (:predicate ringp) + (:constructor internal-make-ring) + (:print-function %print-hring)) + "Used with Ring-Push and friends to implement ring buffers." + (first -1 :type fixnum) ;The index of the first position used. + (bound () :type fixnum) ;The index after the last element. + delete-function ;The function to be called on deletion. + (vector () :type simple-vector)) ;The vector. + +;;; make-ring -- Public +;;; +;;; Make a new empty ring with some maximum size and type. +;;; +(defun make-ring (size &optional (delete-function #'identity)) + "Make a ring-buffer which can hold up to Size objects. Delete-Function + is a function which is called with each object that falls off the + end." + (unless (and (fixnump size) (> size 0)) + (error "Ring size, ~S is not a positive fixnum." size)) + (internal-make-ring :delete-function delete-function + :vector (make-array size) + :bound (1- (- size)))) + +;;; ring-push -- Public +;;; +;;; Decrement first modulo the maximum size, delete any old +;;; element, and add the new one. +;;; +(defun ring-push (object ring) + "Push an object into a ring, deleting an element if necessary." + (let ((first (ring-first ring)) + (vec (ring-vector ring)) victim) + (declare (simple-vector vec) (fixnum first victim)) + (cond + ;; If zero, wrap around to end. + ((zerop first) + (setq victim (1- (length vec)))) + ;; If empty then fix up pointers. + ((minusp first) + (setf (ring-bound ring) 0) + (setq victim (1- (length vec)))) + (t + (setq victim (1- first)))) + (when (= first (ring-bound ring)) + (funcall (ring-delete-function ring) (aref vec victim)) + (setf (ring-bound ring) victim)) + (setf (ring-first ring) victim) + (setf (aref vec victim) object))) + + +;;; ring-pop -- Public +;;; +;;; Increment first modulo the maximum size. +;;; +(defun ring-pop (ring) + "Pop an object from a ring and return it." + (let* ((first (ring-first ring)) + (vec (ring-vector ring)) + (new (if (= first (1- (length vec))) 0 (1+ first))) + (bound (ring-bound ring))) + (declare (fixnum first new bound) (simple-vector vec)) + (cond + ((minusp bound) + (error "Cannot pop from an empty ring.")) + ((= new bound) + (setf (ring-first ring) -1 (ring-bound ring) (1- (- (length vec))))) + (t + (setf (ring-first ring) new))) + (shiftf (aref vec first) nil))) + + +;;; ring-length -- Public +;;; +;;; Return the current and maximum size. +;;; +(defun ring-length (ring) + "Return as values the current and maximum size of a ring." + (let ((diff (- (ring-bound ring) (ring-first ring))) + (max (length (ring-vector ring)))) + (declare (fixnum diff max)) + (values (if (plusp diff) diff (+ max diff)) max))) + +;;; ring-ref -- Public +;;; +;;; Do modulo arithmetic to find the correct element. +;;; +(defun ring-ref (ring index) + (declare (fixnum index)) + "Return the index'th element of a ring. This can be set with Setf." + (let ((first (ring-first ring))) + (declare (fixnum first)) + (cond + ((and (zerop index) (not (minusp first))) + (aref (ring-vector ring) first)) + (t + (let* ((diff (- (ring-bound ring) first)) + (sum (+ first index)) + (vec (ring-vector ring)) + (max (length vec))) + (declare (fixnum diff max sum) (simple-vector vec)) + (when (or (>= index (if (plusp diff) diff (+ max diff))) + (minusp index)) + (error "Ring index ~D out of bounds." index)) + (aref vec (if (>= sum max) (- sum max) sum))))))) + + +;;; %set-ring-ref -- Internal +;;; +;;; Setf form for ring-ref, set a ring element. +;;; +(defun %set-ring-ref (ring index value) + (declare (fixnum index)) + (let* ((first (ring-first ring)) + (diff (- (ring-bound ring) first)) + (sum (+ first index)) + (vec (ring-vector ring)) + (max (length vec))) + (declare (fixnum diff first max) (simple-vector vec)) + (when (or (>= index (if (plusp diff) diff (+ max diff))) (minusp index)) + (error "Ring index ~D out of bounds." index)) + (setf (aref vec (if (>= sum max) (- sum max) sum)) value))) + +(eval-when (compile eval) +(defmacro 1+m (exp base) + `(if (= ,exp ,base) 0 (1+ ,exp))) +(defmacro 1-m (exp base) + `(if (zerop ,exp) ,base (1- ,exp))) +) ;eval-when (compile eval) + +;;; rotate-ring -- Public +;;; +;;; Rotate a ring, blt'ing elements as necessary. +;;; +(defun rotate-ring (ring offset) + "Rotate a ring forward, i.e. second -> first, with positive offset, + or backwards with negative offset." + (declare (fixnum offset)) + (let* ((first (ring-first ring)) + (bound (ring-bound ring)) + (vec (ring-vector ring)) + (max (length vec))) + (declare (fixnum first bound max) (simple-vector vec)) + (cond + ((= first bound) + (let ((new (rem (+ offset first) max))) + (declare (fixnum new)) + (if (minusp new) (setq new (+ new max))) + (setf (ring-first ring) new) + (setf (ring-bound ring) new))) + ((not (minusp first)) + (let* ((diff (- bound first)) + (1-max (1- max)) + (length (if (plusp diff) diff (+ max diff))) + (off (rem offset length))) + (declare (fixnum diff length off 1-max)) + (cond + ((minusp offset) + (do ((dst (1-m first 1-max) (1-m dst 1-max)) + (src (1-m bound 1-max) (1-m src 1-max)) + (cnt off (1+ cnt))) + ((zerop cnt) + (setf (ring-first ring) (1+m dst 1-max)) + (setf (ring-bound ring) (1+m src 1-max))) + (declare (fixnum dst src cnt)) + (shiftf (aref vec dst) (aref vec src) nil))) + (t + (do ((dst bound (1+m dst 1-max)) + (src first (1+m src 1-max)) + (cnt off (1- cnt))) + ((zerop cnt) + (setf (ring-first ring) src) + (setf (ring-bound ring) dst)) + (declare (fixnum dst src cnt)) + (shiftf (aref vec dst) (aref vec src) nil)))))))) + ring) diff --git a/hemlock/rompsite.lisp b/hemlock/rompsite.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6bef157eee7a1835e98ca4a4053fde79f1a733e6 --- /dev/null +++ b/hemlock/rompsite.lisp @@ -0,0 +1,1538 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; "Site dependent" stuff for the editor while on the IBM RT PC machine. +;;; + +(in-package "SYSTEM") + +(export '(without-hemlock)) + + +(in-package "HEMLOCK-INTERNALS" :nicknames '("HI")) + +(export '(show-mark editor-sleep text-character print-pretty-character + *input-transcript* *real-editor-input* input-waiting + fun-defined-from-pathname editor-describe-function pause-hemlock + store-cut-string fetch-cut-string schedule-event + remove-scheduled-event enter-window-autoraise directoryp + last-key-event-cursorpos merge-relative-pathnames *editor-input* + *last-character-typed* *character-history* + ;; + ;; Export default-font to prevent a name conflict that occurs due to + ;; the Hemlock variable "Default Font" defined in SITE-INIT below. + ;; + default-font)) + + +;;; SYSTEM:WITHOUT-HEMLOCK -- Public. +;;; +;;; Code:lispinit.lisp uses this for a couple interrupt handlers, and +;;; eval-server.lisp. +;;; +(defmacro system:without-hemlock (&body body) + "When in the editor and not in the debugger, call the exit method of Hemlock's + device, so we can type. Do the same thing on exit but call the init method." + `(progn + (when (and *in-the-editor* (not debug::*in-the-debugger*)) + (let ((device (device-hunk-device (window-hunk (current-window))))) + (funcall (device-exit device) device))) + ,@body + (when (and *in-the-editor* (not debug::*in-the-debugger*)) + (let ((device (device-hunk-device (window-hunk (current-window))))) + (funcall (device-init device) device))))) + + + +;;;; SITE-INIT. + +;;; *character-history* is defined much later in this file, but it needs to +;;; be set in SITE-INIT, since MAKE-RING doesn't exist at load time for this +;;; file. +;;; +(proclaim '(special *character-history*)) + +;;; SITE-INIT -- Internal +;;; +;;; This function is called at init time to set up any site stuff. +;;; +(defun site-init () + (defhvar "Beep Border Width" + "Width in pixels of the border area inverted by beep." + :value 20) + (defhvar "Default Window Width" + "This is used to make a window when prompting the user. The value is in + characters." + :value 80) + (defhvar "Default Window Height" + "This is used to make a window when prompting the user. The value is in + characters." + :value 24) + (defhvar "Default Initial Window Width" + "This is used when Hemlock first starts up to make its first window. + The value is in characters." + :value 80) + (defhvar "Default Initial Window Height" + "This is used when Hemlock first starts up to make its first window. + The value is in characters." + :value 24) + (defhvar "Default Initial Window X" + "This is used when Hemlock first starts up to make its first window. + The value is in pixels." + :value nil) + (defhvar "Default Initial Window Y" + "This is used when Hemlock first starts up to make its first window. + The value is in pixels." + :value nil) + (defhvar "Bell Style" + "This controls what beeps do in Hemlock. Acceptable values are :border-flash + (which is the default), :feep, :border-flash-and-feep, :flash, + :flash-and-feep, and NIL (do nothing)." + :value :border-flash) + (defhvar "Reverse Video" + "Paints white on black in window bodies, black on white in modelines." + :value nil + :hooks '(reverse-video-hook-fun)) + (defhvar "Cursor Bitmap File" + "File to read to setup cursors for Hemlock windows. The mask is found by + merging this name with \".mask\"." + :value "/usr/misc/.lisp/lib/hemlock11.cursor") + (defhvar "Enter Window Hook" + "When the mouse enters an editor window, this hook is invoked. These + functions take the Hemlock Window as an argument." + :value nil) + (defhvar "Exit Window Hook" + "When the mouse exits an editor window, this hook is invoked. These + functions take the Hemlock Window as an argument." + :value nil) + (defhvar "Set Window Autoraise" + "When non-nil, setting the current window will automatically raise that + window via a function on \"Set Window Hook\". If the value is :echo-only + (the default), then only the echo area window will be raised + automatically upon becoming current." + :value :echo-only) + (defhvar "Default Font" + "The string name of the font to be used for Hemlock -- buffer text, + modelines, random typeout, etc. The font is loaded when initializing + Hemlock." + :value "8x13") + (defhvar "Thumb Bar Meter" + "When non-nil (the default), windows will be created to be displayed with + a ruler in the bottom border of the window." + :value t) + + (setf *character-history* (make-ring 60)) + nil) + + + +;;;; Some generally useful file-system functions. + +;;; MERGE-RELATIVE-PATHNAMES takes a pathname that is either absolute or +;;; relative to default-dir, merging it as appropriate and returning a definite +;;; directory pathname. If the component comes back with a trailing slash, we +;;; have to remove it to get the MERGE-PATHNAMES to work correctly. The result +;;; must have a trailing slash. +;;; +(defun merge-relative-pathnames (pathname default-directory) + "Merges pathname with default-directory. If pathname is not absolute, it + is assumed to be relative to default-directory. The result is always a + directory." + (setf pathname (pathname pathname)) + (flet ((return-with-slash (pathname) + (let ((ns (namestring pathname))) + (declare (simple-string ns)) + (if (char= #\/ (schar ns (1- (length ns)))) + pathname + (pathname (concatenate 'simple-string ns "/")))))) + (let ((dir (pathname-directory pathname))) + (if dir + (let ((dev (pathname-device pathname))) + (if (eq dev :absolute) + (return-with-slash pathname) + (return-with-slash + (make-pathname :device (pathname-device default-directory) + :directory + (concatenate + 'simple-vector + (pathname-directory default-directory) + dir) + :defaults pathname)))) + (return-with-slash (merge-pathnames pathname default-directory)))))) + +(defun directoryp (pathname) + (not (or (pathname-name pathname) (pathname-type pathname)))) + + + +;;;; I/O specials and initialization + +(defvar *editor-input* nil + "Input stream to get unechoed unbuffered terminal input.") + +(defvar *real-editor-input* () + "The real editor input stream. Useful when we want to read from the + terminal when *editor-input* is rebound.") + + +;;; File descriptor for the terminal. +;;; +(defvar *editor-file-descriptor*) + + +;;; This is a hack, so screen can tell how to initialize screen management +;;; without re-opening the display. It is set in INIT-RAW-IO and referenced +;;; in WINDOWED-MONITOR-P. +;;; +(defvar *editor-windowed-input* nil) + + +;;; These are used for selecting X events. +;;; +;;; This says to send :key-press, :button-press, :button-release, :enter-notify, +;;; and :leave-notify events. +;;; +(defconstant input/boundary-xevents-selection-keys + '(:key-press :button-press :button-release :enter-window :leave-window)) +(defconstant input/boundary-xevents-mask + (apply #'xlib:make-event-mask input/boundary-xevents-selection-keys)) +;;; +;;; This says to send :exposure, :destroy-notify, :unmap-notify, :map-notify, +;;; :reparent-notify, :configure-notify, :gravity-notify, and :circulate-notify +;;; in addition to the above events. Of those enumerated here, we only care +;;; about :exposure and :configure-notify. +;;; +(defconstant interesting-xevents-receive-keys + '(:key-press :button-press :button-release :enter-notify :leave-notify + :exposure :graphics-exposure :configure-notify :destroy-notify :unmap-notify + :map-notify :reparent-notify :gravity-notify :circulate-notify)) +(defconstant interesting-xevents-mask + (apply #'xlib:make-event-mask + (append input/boundary-xevents-selection-keys + '(:exposure :structure-notify)))) + +(defconstant random-typeout-xevents-mask + (apply #'xlib:make-event-mask + (append input/boundary-xevents-selection-keys + '(:exposure)))) + + +(proclaim '(special ed::*open-paren-highlight-font* + ed::*active-region-highlight-font*)) + +(defparameter lisp-fonts-pathnames + '("/usr/misc/.lisp/lib/fonts/" + "/afs/cs.cmu.edu/unix/rt_mach/omega/usr/misc/.lisp/lib/fonts/")) + + +;;; INIT-RAW-IO -- Internal +;;; +;;; This function should be called whenever the editor is entered in a new +;;; lisp. It sets up process specific data structures. +;;; +(defun init-raw-io (display) + (setf *editor-windowed-input* nil) + (cond (display + (setf *editor-windowed-input* (ext:open-clx-display display)) + (setf *editor-input* (make-editor-window-input-stream)) + (ext:carefully-add-font-paths *editor-windowed-input* + lisp-fonts-pathnames) + (setup-font-family *editor-windowed-input* + (variable-value 'ed::default-font) + "8x13u" "8x13bold")) + (t ;; The editor's file descriptor is Unix standard input (0). + ;; We don't need to affect system:*file-input-handlers* here + ;; because the init and exit methods for tty redisplay devices + ;; take care of this. + ;; + (setf *editor-file-descriptor* 0) + (setf *editor-input* (make-editor-tty-input-stream 0)))) + (setf *real-editor-input* *editor-input*) + *editor-windowed-input*) + +;;; Stop flaming from compiler due to CLX macros expanding into illegal +;;; declarations. +;;; +(proclaim '(declaration values)) +(proclaim '(special *default-font-family*)) + +;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would +;;; assume it to be special, issuing a nasty warning. +;;; +(defconstant font-map-size 16 + "The number of possible fonts in a font-map.") + + +;;; SETUP-FONT-FAMILY sets *default-font-family*, opening the three font names +;;; passed in. The font family structure is filled in from the first argument. +;;; Actually, this ignores default-highlight-font and default-open-paren-font +;;; in lieu of "Active Region Highlighting Font" and "Open Paren Highlighting +;;; Font" when these are defined. +;;; +(defun setup-font-family (display default-font default-highlight-font + default-open-paren-font) + (let* ((font-family (make-font-family :map (make-array font-map-size + :initial-element 0) + :cursor-x-offset 0 + :cursor-y-offset 0)) + (font-family-map (font-family-map font-family))) + (declare (simple-vector font-family-map)) + (setf *default-font-family* font-family) + (let ((font (xlib:open-font display default-font))) + (unless font (error "Cannot open font -- ~S" default-font)) + (fill font-family-map font) + (let ((width (xlib:max-char-width font))) + (setf (font-family-width font-family) width) + (setf (font-family-cursor-width font-family) width)) + (let* ((baseline (xlib:font-ascent font)) + (height (+ baseline (xlib:font-descent font)))) + (setf (font-family-height font-family) height) + (setf (font-family-cursor-height font-family) height) + (setf (font-family-baseline font-family) baseline))) + (setup-one-font display + (or (variable-value 'ed::open-paren-highlighting-font) + default-open-paren-font) + font-family-map + ed::*open-paren-highlight-font*) + (setup-one-font display + (or (variable-value 'ed::active-region-highlighting-font) + default-highlight-font) + font-family-map + ed::*active-region-highlight-font*))) + +;;; SETUP-ONE-FONT tries to open font-name for display, storing the result in +;;; font-family-map at index. XLIB:OPEN-FONT will return font stuff regardless +;;; if the request is valid or not, so we finish the output to get synch'ed +;;; with the server which will cause any errors to get signaled. At this +;;; level, we want to deal with this error here returning nil if the font +;;; couldn't be opened. +;;; +(defun setup-one-font (display font-name font-family-map index) + (handler-case (let ((font (xlib:open-font display (namestring font-name)))) + (xlib:display-finish-output display) + (setf (svref font-family-map index) font)) + (xlib:name-error () + (warn "Cannot open font -- ~S" font-name) + nil))) + + + +;;;; HEMLOCK-BEEP. + +(defvar *editor-bell* (make-string 1 :initial-element #\bell)) + +;;; TTY-BEEP is used in Hemlock for beeping when running under a terminal. +;;; Send a #\bell to unix standard output. +;;; +(defun tty-beep (&optional device stream) + (declare (ignore device stream)) + (when (variable-value 'ed::bell-style) + (mach:unix-write 1 *editor-bell* 0 1))) + +(proclaim '(special *current-window*)) + +;;; BITMAP-BEEP is used in Hemlock for beeping when running under windowed +;;; input. +;;; +(defun bitmap-beep (display stream) + (declare (ignore stream)) + (ecase (variable-value 'ed::bell-style) + (:border-flash + (flash-window-border *current-window*)) + (:feep + (xlib:bell display) + (xlib:display-force-output display)) + (:border-flash-and-feep + (xlib:bell display) + (xlib:display-force-output display) + (flash-window-border *current-window*)) + (:flash + (flash-window *current-window*)) + (:flash-and-feep + (xlib:bell display) + (xlib:display-force-output display) + (flash-window *current-window*)) + ((nil) ;Do nothing. + ))) + +(proclaim '(special *foreground-background-xor*)) + +(defun flash-window-border (window) + (let* ((hunk (window-hunk window)) + (xwin (bitmap-hunk-xwindow hunk)) + (gcontext (bitmap-hunk-gcontext hunk)) + (display (bitmap-device-display (device-hunk-device hunk))) + (border (variable-value 'ed::beep-border-width)) + (h (or (bitmap-hunk-modeline-pos hunk) (bitmap-hunk-height hunk))) + (top-border (min (ash h -1) border)) + (w (bitmap-hunk-width hunk)) + (side-border (min (ash w -1) border)) + (top-width (max 0 (- w (ash side-border 1)))) + (right-x (- w side-border)) + (bottom-y (- h top-border))) + (xlib:with-gcontext (gcontext :function xlib::boole-xor + :foreground *foreground-background-xor*) + (dotimes (i 8) + (xlib:draw-rectangle xwin gcontext 0 0 side-border h t) + (xlib:display-force-output display) + (xlib:draw-rectangle xwin gcontext side-border bottom-y + top-width top-border t) + (xlib:display-force-output display) + (xlib:draw-rectangle xwin gcontext right-x 0 side-border h t) + (xlib:display-force-output display) + (xlib:draw-rectangle xwin gcontext side-border 0 top-width top-border t) + (xlib:display-force-output display))))) + +(defun flash-window (window) + (let* ((hunk (window-hunk window)) + (xwin (bitmap-hunk-xwindow hunk)) + (gcontext (bitmap-hunk-gcontext hunk)) + (display (bitmap-device-display (device-hunk-device hunk))) + (width (bitmap-hunk-width hunk)) + (height (or (bitmap-hunk-modeline-pos hunk) + (bitmap-hunk-height hunk)))) + (xlib:with-gcontext (gcontext :function xlib::boole-xor + :foreground *foreground-background-xor*) + (xlib:draw-rectangle xwin gcontext 0 0 width height t) + (xlib:display-force-output display) + (xlib:draw-rectangle xwin gcontext 0 0 width height t) + (xlib:display-force-output display)))) + + + +(defun hemlock-beep (stream) + "Using the current window, calls the device's beep function on stream." + (let ((device (device-hunk-device (window-hunk (current-window))))) + (funcall (device-beep device) (bitmap-device-display device) stream))) + + + +;;;; GC messages. + +;;; HEMLOCK-GC-NOTIFY-BEFORE and HEMLOCK-GC-NOTIFY-AFTER both MESSAGE GC +;;; notifications when Hemlock is not running under X11. It cannot affect +;;; its window's without using its display connection. Since GC can occur +;;; inside CLX request functions, using the same display confuses CLX. +;;; + +(defun hemlock-gc-notify-before (bytes-in-use) + (let ((control "~%[GC threshold exceeded with ~:D bytes in use. ~ + Commencing GC.]~%")) + (cond ((not hi::*editor-windowed-input*) + (beep) + #|(message control bytes-in-use)|#) + (t + ;; Can't call BEEP since it would use Hemlock's display connection. + (lisp::default-beep-function *standard-output*) + (format t control bytes-in-use) + (finish-output))))) + +(defun hemlock-gc-notify-after (bytes-retained bytes-freed trigger) + (let ((control + "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%~ + [GC will next occur when at least ~:D bytes are in use.]~%")) + (cond ((not hi::*editor-windowed-input*) + (beep) + #|(message control bytes-retained bytes-freed)|#) + (t + ;; Can't call BEEP since it would use Hemlock's display connection. + (lisp::default-beep-function *standard-output*) + (format t control bytes-retained bytes-freed trigger) + (finish-output))))) + + + +;;;; Site-Wrapper-Macro and standard device init/exit functions. + +(defun in-hemlock-standard-input-read (stream &rest ignore) + (declare (ignore ignore)) + (error "You cannot read off this stream while in Hemlock -- ~S" + stream)) + +(defvar *illegal-read-stream* + (lisp::make-stream :in #'in-hemlock-standard-input-read)) + +(defmacro site-wrapper-macro (&body body) + `(unwind-protect + (progn + (when *editor-has-been-entered* + (let ((device (device-hunk-device (window-hunk (current-window))))) + (funcall (device-init device) device))) + (let ((*beep-function* #'hemlock-beep) + (*gc-notify-before* #'hemlock-gc-notify-before) + (*gc-notify-after* #'hemlock-gc-notify-after) + (*standard-input* *illegal-read-stream*) + (*query-io* *illegal-read-stream*)) + (cond ((not *editor-windowed-input*) + ,@body) + (t + (ext:with-clx-event-handling + (*editor-windowed-input* #'ext:object-set-event-handler) + ,@body))))) + (let ((device (device-hunk-device (window-hunk (current-window))))) + (funcall (device-exit device) device)))) + +(defun standard-device-init () + (setup-input)) + +(defun standard-device-exit () + (reset-input)) + +(proclaim '(special *echo-area-window*)) + +;;; Maybe bury/unbury hemlock window when we go to and from Lisp. +;;; This should do something more sophisticated when we know what that is. +;;; +(defun default-hemlock-window-mngt (display on) + (let ((win (bitmap-hunk-xwindow (window-hunk *current-window*))) + (ewin (bitmap-hunk-xwindow (window-hunk *echo-area-window*)))) + (cond (on (setf (xlib:window-priority ewin) :above) + (clear-input *editor-input*) + (setf (xlib:window-priority win) :above)) + (t (setf (xlib:window-priority ewin) :below) + (setf (xlib:window-priority win) :below)))) + (xlib:display-force-output display)) + +(defvar *hemlock-window-mngt* #'default-hemlock-window-mngt + "This function is called by HEMLOCK-WINDOW, passing its arguments. This may + be nil.") + +(defun hemlock-window (display on) + "Calls *hemlock-window-mngt* on the argument ON when *current-window* is + bound. This is called in the device init and exit methods for X bitmap + devices." + (when (and *hemlock-window-mngt* *current-window*) + (funcall *hemlock-window-mngt* display on))) + + + +;;;; Current terminal character translation. + +(defvar *terminal-translation-table* (make-array 128)) + +;;; Converting ASCII control characters to Common Lisp control characters: +;;; ASCII control character codes are separated from the codes of the +;;; "non-controlified" characters by the code of atsign. The ASCII control +;;; character codes range from ^@ (0) through ^_ (one less than the code of +;;; space). We iterate over this range adding the ASCII code of atsign to +;;; get the "non-controlified" character code. With each of these, we turn +;;; the code into a Common Lisp character and set its :control bit. Certain +;;; ASCII control characters have to be translated to special Common Lisp +;;; characters outside of the loop. +;;; With the advent of Hemlock running under X, and all the key bindings +;;; changing, we also downcase each Common Lisp character (where normally +;;; control characters come in upcased) in an effort to obtain normal command +;;; bindings. Commands bound to uppercase modified characters will not be +;;; accessible to terminal interaction. +;;; +(let ((@-code (char-code #\@))) + (dotimes (i (char-code #\space)) + (setf (svref *terminal-translation-table* i) + (set-char-bit (char-downcase (code-char (+ i @-code))) :control t)))) +(setf (svref *terminal-translation-table* 9) #\tab) +(setf (svref *terminal-translation-table* 10) #\linefeed) +(setf (svref *terminal-translation-table* 13) #\return) +(setf (svref *terminal-translation-table* 27) #\alt) +(setf (svref *terminal-translation-table* 8) #\backspace) +;;; +;;; Other ASCII codes are exactly the same as the Common Lisp codes. +;;; +(do ((i (char-code #\space) (1+ i))) + ((= i 128)) + (setf (svref *terminal-translation-table* i) (code-char i))) + +;;; TRANSLATE-TTY-CHAR is our interface to be used in GET-EDITOR-INPUT. +;;; +(proclaim '(inline translate-tty-char)) +(defun translate-tty-char (char) + (svref *terminal-translation-table* char)) + + +(defconstant termcap-file "/etc/termcap") + +(defun cl-termcap-char (char) + (if (char-bit char :control) + (code-char (the fixnum + (- (the fixnum (char-code char)) + 64))) ;(char-code #\@) + (case char + (#\alt (code-char 27)) + (#\newline (code-char 10)) + (#\return (code-char 13)) + (#\tab (code-char 9)) + (#\backspace (code-char 8)) + (#\formfeed (code-char 12)) + (t char)))) + + + +;;;; Common editor input: stream def, event queue mngt, kbdmac waiting, +;;;; more prompt, input method macro. + +;;; This is the basic editor stream definition. More particular stream +;;; definitions below include this. +;;; +(defstruct (editor-input-stream + (:include stream) + (:print-function + (lambda (s stream d) + (declare (ignore s d)) + (write-string "#<Editor-Input stream>" stream))) + (:constructor make-editor-input-stream + (head &optional (tail head)))) + ;; + ;; FIFO queue of events on this stream. The queue always contains + ;; at least one one element, which is the character most recently read. + ;; If no event has been read, the event is a dummy with a NIL char. + head ; First key event in queue. + tail) ; Last event in queue. + + +;;; Key event queue. +;;; + +(defstruct (key-event + (:constructor make-key-event ())) + next ; Next queued event, or NIL if none. + hunk ; Screen hunk event was read from. + char ; Character read. + x ; X and Y character position of mouse cursor. + y + unread-p) + +(defvar *free-key-events* ()) + +(defun new-event (char x y hunk next &optional unread-p) + (let ((res (if *free-key-events* + (shiftf *free-key-events* (key-event-next *free-key-events*)) + (make-key-event)))) + (setf (key-event-char res) char) + (setf (key-event-x res) x) + (setf (key-event-y res) y) + (setf (key-event-hunk res) hunk) + (setf (key-event-next res) next) + (setf (key-event-unread-p res) unread-p) + res)) + +(defvar *last-character-typed* () + "This variable contains the last character typed to the command + interpreter.") + +;;; *character-history* is setup in SITE-INIT. +;;; +(defvar *character-history* nil + "This ring holds the last 60 characters read by the command interpreter.") + +(proclaim '(special *input-transcript*)) + +;;; DQ-EVENT is used in editor stream methods for popping off input. +;;; If there is an event not yet read in Stream, then pop the queue +;;; and return the character. If there is none, return NIL. +;;; +(defun dq-event (stream) + (without-interrupts + (let* ((head (editor-input-stream-head stream)) + (next (key-event-next head))) + (if next + (let ((char (key-event-char next))) + (setf (editor-input-stream-head stream) next) + (shiftf (key-event-next head) *free-key-events* head) + (ring-push char *character-history*) + (setq *last-character-typed* char) + (when *input-transcript* + (vector-push-extend char *input-transcript*)) + char))))) + +;;; Q-EVENT is used in low level input fetching routines to add input to the +;;; editor stream. +;;; +(defun q-event (stream char &optional x y hunk) + (without-interrupts + (let ((new (new-event char x y hunk nil)) + (tail (editor-input-stream-tail stream))) + (setf (key-event-next tail) new) + (setf (editor-input-stream-tail stream) new)))) + +(defun un-event (char stream) + (without-interrupts + (let* ((head (editor-input-stream-head stream)) + (next (key-event-next head)) + (new (new-event char (key-event-x head) (key-event-y head) + (key-event-hunk head) next t))) + (setf (key-event-next head) new) + (unless next (setf (editor-input-stream-tail stream) new))))) + + +;;; Keyboard macro hacks. +;;; + +(defvar *input-transcript* () + "If this variable is non-null then it should contain an adjustable vector + with a fill pointer into which all keyboard input will be pushed.") + +;;; INPUT-WAITING -- Internal +;;; +;;; An Evil hack that tells us whether there is an unread character on +;;; *editor-input*. Note that this is applied to the real *editor-input* +;;; rather than to a kbdmac stream. +;;; +(defun input-waiting () + "Returns true if there is a character which has been unread-char'ed + on *editor-input*. Used by the keyboard macro stuff." + (let ((next (key-event-next (editor-input-stream-head *real-editor-input*)))) + (and next (key-event-unread-p next)))) + + +;;; Random typeout hacks. +;;; + +(defun wait-for-more (stream) + (let ((ch (more-read-ch))) + (cond ((logical-char= ch :yes)) + ((or (logical-char= ch :do-all) + (logical-char= ch :exit)) + (setf (random-typeout-stream-no-prompt stream) t) + (random-typeout-cleanup stream)) + ((logical-char= ch :keep) + (setf (random-typeout-stream-no-prompt stream) t) + (maybe-keep-random-typeout-window stream) + (random-typeout-cleanup stream)) + ((logical-char= ch :no) + (random-typeout-cleanup stream) + (throw 'more-punt nil)) + (t + (unread-char ch *editor-input*) + (random-typeout-cleanup stream) + (throw 'more-punt nil))))) + +(proclaim '(special *more-prompt-action*)) + +(defun maybe-keep-random-typeout-window (stream) + (let* ((window (random-typeout-stream-window stream)) + (buffer (window-buffer window)) + (start (buffer-start-mark buffer))) + (when (typep (hi::device-hunk-device (hi::window-hunk window)) + 'hi::bitmap-device) + (let ((*more-prompt-action* :normal)) + (update-modeline-field buffer window :more-prompt) + (random-typeout-redisplay window)) + (buffer-start (buffer-point buffer)) + (unless (make-window start :window (make-xwindow-like-hwindow window)) + (editor-error "Could not create random typeout window."))))) + +(defun end-random-typeout (stream) + (let ((*more-prompt-action* :flush) + (window (random-typeout-stream-window stream))) + (update-modeline-field (window-buffer window) window :more-prompt) + (random-typeout-redisplay window)) + (unless (random-typeout-stream-no-prompt stream) + (let* ((ch (more-read-ch)) + (keep-p (logical-char= ch :keep))) + (when keep-p (maybe-keep-random-typeout-window stream)) + (random-typeout-cleanup stream) + (unless (or (logical-char= ch :do-all) + (logical-char= ch :exit) + (logical-char= ch :no) + (logical-char= ch :yes) + keep-p) + (unread-char ch *editor-input*))))) + +;;; MORE-READ-CH gets some input from the type of stream bound to +;;; *editor-input*. Need to loop over SERVE-EVENT since it returns on any kind +;;; of event (not necessarily a key or button event). +;;; +;;; Currently this does not work for keyboard macro streams! +;;; +(defun more-read-ch () + (clear-input *editor-input*) + (let ((ch (do ((ch (dq-event *editor-input*) (dq-event *editor-input*))) + (ch ch) + (system:serve-event)))) + (when (or (char= ch #\control-g) (char= ch #\control-\g)) + (beep) + (throw 'editor-top-level-catcher nil)) + ch)) + + +;;; Input method macro. +;;; + +(defvar *in-hemlock-stream-input-method* nil + "This keeps us from undefined nasties like re-entering Hemlock stream + input methods from input hooks and scheduled events.") + +(proclaim '(special *screen-image-trashed*)) + +;;; EDITOR-INPUT-METHOD-MACRO is used in EDITOR-TTY-IN and EDITOR-WINDOW-IN. +;;; Somewhat odd stuff goes on here because this is the place where Hemlock +;;; waits, so this is where we redisplay, check the time for scheduled +;;; events, etc. In the loop, we call the input hook when we get a character +;;; and leave the loop. If there isn't any input, invoke any scheduled +;;; events whose time is up. Unless SERVE-EVENT returns immediately and did +;;; something, (serve-event 0), call redisplay, note that we are going into +;;; a read wait, and call SERVE-EVENT with a wait or infinite timeout. Upon +;;; exiting the loop, turn off the read wait note and check for the abort +;;; character. Return the character we got. +;;; We bind an error condition handler here because the default Hemlock +;;; error handler goes into a little debugging prompt loop, but if we got +;;; an error in getting input, we should prompt the user using the input +;;; method (recursively even). +;;; +(eval-when (compile eval) +(defmacro editor-input-method-macro (&optional screen-image-trashed-concern) + `(handler-bind ((error #'(lambda (condition) + (let ((device (device-hunk-device + (window-hunk (current-window))))) + (funcall (device-exit device) device)) + (invoke-debugger condition)))) +; (when *in-hemlock-stream-input-method* +; (error "Entering Hemlock stream input method recursively!")) + (let ((*in-hemlock-stream-input-method* t) + (nrw-fun (device-note-read-wait + (device-hunk-device (window-hunk (current-window))))) + char) + (loop + (when (setf char (dq-event stream)) + (dolist (f (variable-value 'ed::input-hook)) (funcall f)) + (return)) + (invoke-scheduled-events) + (unless (system:serve-event 0) + (internal-redisplay) + ,@(if screen-image-trashed-concern + '((when *screen-image-trashed* (internal-redisplay)))) + (when nrw-fun (funcall nrw-fun t)) + (let ((wait (next-scheduled-event-wait))) + (if wait (system:serve-event wait) (system:serve-event))))) + (when nrw-fun (funcall nrw-fun nil)) + (when (and (or (char= char #\control-g) (char= char #\control-\g)) + eof-error-p) + (beep) + (throw 'editor-top-level-catcher nil)) + char))) +) ;eval-when + + + +;;;; Editor tty input streams. + +(defstruct (editor-tty-input-stream + (:include editor-input-stream + (:in #'editor-tty-in) + (:misc #'editor-tty-misc)) + (:print-function + (lambda (obj stream n) + (declare (ignore obj n)) + (write-string "#<Editor-Tty-Input stream>" stream))) + (:constructor make-editor-tty-input-stream + (fd &optional (head (make-key-event)) (tail head)))) + fd) + + +(defun editor-tty-misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (case operation + (:listen (cond ((key-event-next (editor-input-stream-head stream)) t) + ((editor-tty-listen stream) t) + (t nil))) + (:unread + (un-event arg1 stream)) + (:clear-input + (without-interrupts + (let* ((head (editor-input-stream-head stream)) + (next (key-event-next head))) + (when next + (setf (key-event-next head) nil) + (shiftf (key-event-next (editor-input-stream-tail stream)) + *free-key-events* next) + (setf (editor-input-stream-tail stream) head))))) + (:element-type 'character))) + + +(defun editor-tty-in (stream eof-error-p eof-value) + (declare (ignore eof-value)) + (editor-input-method-macro t)) + + + +;;;; Editor window input streams. + +(defstruct (editor-window-input-stream + (:include editor-input-stream + (:in #'editor-window-in) + (:misc #'editor-window-misc)) + (:print-function + (lambda (s stream d) + (declare (ignore s d write)) + (write-string "#<Editor-Window-Input stream>" stream))) + (:constructor make-editor-window-input-stream + (&optional (head (make-key-event)) (tail head)))) + hunks) ; List of bitmap-hunks which input to this stream. + + +(defun editor-window-misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (case operation + (:listen + (loop (unless (system:serve-event 0) + ;; If nothing is pending, check the queued input. + (return (not (null (key-event-next + (editor-input-stream-head stream)))))) + (when (key-event-next (editor-input-stream-head stream)) + ;; Don't service anymore events if we just got some input. + (return t)))) + (:unread + (un-event arg1 stream)) + (:clear-input + (loop (unless (system:serve-event 0) (return))) + (without-interrupts + (let* ((head (editor-input-stream-head stream)) + (next (key-event-next head))) + (when next + (setf (key-event-next head) nil) + (shiftf (key-event-next (editor-input-stream-tail stream)) + *free-key-events* next) + (setf (editor-input-stream-tail stream) head))))) + (:element-type 'character))) + + +(defun editor-window-in (stream eof-error-p eof-value) + (declare (ignore eof-value)) + (editor-input-method-macro)) + + + +;;; LAST-KEY-EVENT-CURSORPOS -- Public +;;; +;;; Just look up the saved info in the last read key event. +;;; +(defun last-key-event-cursorpos () + "Return as values, the (X, Y) character position and window where the + last key event happened. If this cannot be determined, Nil is returned. + If in the modeline, return a Y position of NIL and the correct X and window. + Returns nil for terminal input." + (let* ((ev (editor-input-stream-head *real-editor-input*)) + (hunk (key-event-hunk ev)) + (window (and hunk (device-hunk-window hunk)))) + (when window + (values (key-event-x ev) (key-event-y ev) window)))) + + +;;; Window-Input-Handler -- Internal +;;; +;;; This is the input-handler function for hunks that implement windows. +;;; It just queues the events on the *real-editor-input* stream. +;;; +(defun window-input-handler (hunk char x y) + (q-event *real-editor-input* char x y hunk)) + + + +;;;; Event scheduling. + +;;; The time queue provides a ROUGH mechanism for scheduling events to +;;; occur after a given amount of time has passed, optionally repeating +;;; using the given time as an interval for rescheduling. When the input +;;; loop goes around, it will check the current time and process all events +;;; that should have happened before or at this time. The function gets +;;; called on the number of seconds that have elapsed since it was last +;;; called. +;;; +;;; NEXT-SCHEDULED-EVENT-WAIT and INVOKE-SCHEDULED-EVENTS are used in the +;;; editor stream in methods. +;;; +;;; SCHEDULE-EVENT and REMOVE-SCHEDULED-EVENT are exported interfaces. + +(defstruct (tq-event (:print-function print-tq-event) + (:constructor make-tq-event + (time last-time interval function))) + time ; When the event should happen. + last-time ; When the event was scheduled. + interval ; When non-nil, how often the event should happen. + function) ; What to do. + +(defun print-tq-event (obj stream n) + (declare (ignore n)) + (format stream "#<Tq-Event ~S>" (tq-event-function obj))) + +(defvar *time-queue* nil + "This is the time priority queue used in Hemlock input streams for event + scheduling.") + +;;; QUEUE-TIME-EVENT inserts event into the time priority queue *time-queue*. +;;; Event is inserted before the first element that it is less than (which +;;; means that it gets inserted after elements that are the same). +;;; *time-queue* is returned. +;;; +(defun queue-time-event (event) + (let ((time (tq-event-time event))) + (if *time-queue* + (if (< time (tq-event-time (car *time-queue*))) + (push event *time-queue*) + (do ((prev *time-queue* rest) + (rest (cdr *time-queue*) (cdr rest))) + ((or (null rest) + (< time (tq-event-time (car rest)))) + (push event (cdr prev)) + *time-queue*))) + (push event *time-queue*)))) + +;;; NEXT-SCHEDULED-EVENT-WAIT returns nil or the number of seconds to wait for +;;; the next event to happen. +;;; +(defun next-scheduled-event-wait () + (if *time-queue* + (let ((wait (round (- (tq-event-time (car *time-queue*)) + (get-internal-real-time)) + internal-time-units-per-second))) + (if (plusp wait) wait 0)))) + +;;; INVOKE-SCHEDULED-EVENTS invokes all the functions in *time-queue* whose +;;; time has come. If we run out of events, or there are none, then we get +;;; out. If we popped an event whose time hasn't come, we push it back on the +;;; queue. Each function is called on how many seconds, roughly, went by since +;;; the last time it was called (or scheduled). If it has an interval, we +;;; re-queue it. While invoking the function, bind *time-queue* to nothing in +;;; case the event function tries to read off *editor-input*. +;;; +(defun invoke-scheduled-events () + (let ((time (get-internal-real-time))) + (loop + (unless *time-queue* (return)) + (let* ((event (car *time-queue*)) + (event-time (tq-event-time event))) + (cond ((>= time event-time) + (let ((*time-queue* nil)) + (funcall (tq-event-function event) + (round (- time (tq-event-last-time event)) + internal-time-units-per-second))) + (without-interrupts + (let ((interval (tq-event-interval event))) + (when interval + (setf (tq-event-time event) (+ time interval)) + (setf (tq-event-last-time event) time) + (pop *time-queue*) + (queue-time-event event))))) + (t (return))))))) + +(defun schedule-event (time function &optional (repeat t)) + "This causes function to be called after time seconds have passed, + optionally repeating every time seconds. This is a rough mechanism + since commands can take an arbitrary amount of time to run; the function + will be called at the first possible moment after time has elapsed. + Function takes the time that has elapsed since the last time it was + called (or since it was scheduled for the first invocation)." + (let ((now (get-internal-real-time)) + (itime (* internal-time-units-per-second time))) + (queue-time-event (make-tq-event (+ itime now) now (if repeat itime) + function)))) + +(defun remove-scheduled-event (function) + "Removes function queued with SCHEDULE-EVENT." + (setf *time-queue* (delete function *time-queue* :key #'tq-event-function))) + + + +;;;; Editor sleeping. + +(defun editor-sleep (time) + "Sleep for approximately Time seconds." + (unless (or (zerop time) (listen *editor-input*)) + (internal-redisplay) + (sleep-for-time time) + nil)) + +(defun sleep-for-time (time) + (let ((nrw-fun (device-note-read-wait + (device-hunk-device (window-hunk (current-window))))) + (end (+ (get-internal-real-time) + (truncate (* time internal-time-units-per-second))))) + (loop + (when (listen *editor-input*) (return)) + (let ((left (- end (get-internal-real-time)))) + (unless (plusp left) (return nil)) + (when nrw-fun (funcall nrw-fun t)) + (system:serve-event (/ (float left) + (float internal-time-units-per-second))))) + (when nrw-fun (funcall nrw-fun nil)))) + + + +;;;; Showing a mark. + +(defun show-mark (mark window time) + "Highlights the position of Mark within Window for Time seconds, + possibly by moving the cursor there. If Mark is not displayed within + Window return NIL. The wait may be aborted if there is pending input." + (let* ((result t)) + (catch 'redisplay-catcher + (redisplay-window window) + (setf result + (multiple-value-bind (x y) (mark-to-cursorpos mark window) + (funcall (device-show-mark + (device-hunk-device (window-hunk window))) + window x y time)))) + result)) + +(defun tty-show-mark (window x y time) + (cond ((listen *editor-input*)) + (x (internal-redisplay) + (let* ((hunk (window-hunk window)) + (device (device-hunk-device hunk))) + (funcall (device-put-cursor device) hunk x y) + (when (device-force-output device) + (funcall (device-force-output device))) + (sleep-for-time time)) + t) + (t nil))) + +(defun bitmap-show-mark (window x y time) + (cond ((listen *editor-input*)) + (x (let* ((hunk (window-hunk window)) + (display (bitmap-device-display (device-hunk-device hunk)))) + (internal-redisplay) + (hunk-show-cursor hunk x y) + (drop-cursor) + (xlib:display-finish-output display) + (sleep-for-time time) + (lift-cursor) + t)) + (t nil))) + + + +;;;; Funny character stuff. + +;;; TEXT-CHARACTER and PRINT-PRETTY-CHARACTER are documented Hemlock primitives. +;;; + +(defun text-character (char) + "Translate a character as read from *editor-input* into one suitable for + inserting into text. If this is not possible, nil is returned." + (cond ((or (char-bit char :meta) + (char-bit char :super) + (char-bit char :hyper)) + nil) + ((char= char #\return) #\newline) + ((char-bit char :control) + (let* ((nchar (char-upcase (make-char char))) + (code (char-code nchar))) + (if (<= 64 code 95) + (code-char (- code 64)) + nil))) + (t char))) + +(defun print-pretty-character (char stream) + "Prints char to stream suitably for documentation, data displays, etc. + Control, Meta, Super, and Hyper bits are shown as C-, M-, S-, and H-, + respectively. If the character is not a standard character other than + #\space or #\newline, and it has a name, then the name is printed." + (when (char-bit char :control) (write-string "C-" stream)) + (when (char-bit char :meta) (write-string "M-" stream)) + (when (char-bit char :super) (write-string "S-" stream)) + (when (char-bit char :hyper) (write-string "H-" stream)) + (let ((code (char-code char)) + (safe-char (make-char char))) + (if (<= (char-code #\!) code (char-code #\~)) + (write-char safe-char stream) + (let ((name (char-name (code-char code)))) + (cond (name (write-string (string-capitalize name) stream)) + ((< code (char-code #\space)) + (write-char #\^ stream) + (write-char (code-char (+ code (char-code #\@))) stream)) + (t + (write-char safe-char stream))))))) + +(defvar *line-wrap-char* #\! + "The character to be displayed to indicate wrapped lines.") + + + +;;;; Function description and defined-from. + +;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object. It +;;; returns a pathname for the file the function was defined in. If it was +;;; not defined in some file, then nil is returned. +;;; +(defun fun-defined-from-pathname (function) + "Takes a symbol or function and returns the pathname for the file the function + was defined in. If it was not defined in some file, nil is returned." + (typecase function + (symbol (fun-defined-from-pathname (careful-symbol-function function))) + (compiled-function + (let* ((string (%primitive header-ref function + system:%function-defined-from-slot)) + (file (subseq string 0 (position #\space string :test #'char=)))) + (declare (simple-string file)) + (if (or (char= #\# (schar file 0)) + (string-equal file "lisp")) + nil + (if (string= file "/.." :end1 3) + (pathname (subseq file + (position #\/ file :test #'char= :start 4))) + (pathname file))))) + (t nil))) + + +(defvar *editor-describe-stream* + (system:make-indenting-stream *standard-output*)) + +;;; EDITOR-DESCRIBE-FUNCTION has to mess around to get indenting streams to +;;; work. These apparently work fine for DESCRIBE, for which they were defined, +;;; but not in general. It seems they don't indent initial text, only that +;;; following a newline, so inside our use of INDENTING-FURTHER, we need some +;;; form before the WRITE-STRING. To get this to work, I had to remove the ~% +;;; from the FORMAT string, and use FRESH-LINE; simply using FRESH-LINE with +;;; the ~% caused an extra blank line. Possibly I should not have glommed onto +;;; this hack whose interface comes from three different packages, but it did +;;; the right thing .... +;;; +;;; Also, we have set INDENTING-STREAM-STREAM to make sure the indenting stream +;;; is based on whatever *standard-output* is when we are called. +;;; +(defun editor-describe-function (fun sym) + "Calls DESCRIBE on fun. If fun is compiled, and its original name is not sym, + then this also outputs any 'function documentation for sym to + *standard-output*." + (describe fun) + (when (and (compiled-function-p fun) + (not (eq (%primitive header-ref fun %function-name-slot) sym))) + (let ((doc (documentation sym 'function))) + (when doc + (format t "~&Function documentation for ~S:" sym) + (setf (lisp::indenting-stream-stream *editor-describe-stream*) + *standard-output*) + (ext:indenting-further *editor-describe-stream* 2 + (fresh-line *editor-describe-stream*) + (write-string doc *editor-describe-stream*)))))) + + + + +;;;; X Stuff. + +;;; Setting window cursors ... +;;; + +(proclaim '(special *default-foreground-pixel* *default-background-pixel*)) + +(defvar *hemlock-cursor* nil "Holds cursor for Hemlock windows.") + +;;; DEFINE-WINDOW-CURSOR in shoved on the "Make Window Hook". +;;; +(defun define-window-cursor (window) + (setf (xlib:window-cursor (bitmap-hunk-xwindow (window-hunk window))) + *hemlock-cursor*)) + +;;; These are set in INIT-BITMAP-SCREEN-MANAGER and REVERSE-VIDEO-HOOK-FUN. +;;; +(defvar *cursor-foreground-color* nil) +(defvar *cursor-background-color* nil) +(defun make-white-color () (xlib:make-color :red 1.0 :green 1.0 :blue 1.0)) +(defun make-black-color () (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)) + + +;;; GET-HEMLOCK-CURSOR is used in INIT-BITMAP-SCREEN-MANAGER to load the +;;; hemlock cursor for DEFINE-WINDOW-CURSOR. +;;; +(defun get-hemlock-cursor (display) + (when *hemlock-cursor* (xlib:free-cursor *hemlock-cursor*)) + (let* ((cursor-file (truename (variable-value 'ed::cursor-bitmap-file))) + (mask-file (probe-file (make-pathname :type "mask" + :defaults cursor-file))) + (root (xlib:screen-root (xlib:display-default-screen display))) + (mask-pixmap (if mask-file (get-cursor-pixmap root mask-file)))) + (multiple-value-bind (cursor-pixmap cursor-x-hot cursor-y-hot) + (get-cursor-pixmap root cursor-file) + (setf *hemlock-cursor* + (xlib:create-cursor :source cursor-pixmap :mask mask-pixmap + :x cursor-x-hot :y cursor-y-hot + :foreground *cursor-foreground-color* + :background *cursor-background-color*)) + (xlib:free-pixmap cursor-pixmap) + (when mask-pixmap (xlib:free-pixmap mask-pixmap))))) + +(defun get-cursor-pixmap (root pathname) + (let* ((image (xlib:read-bitmap-file pathname)) + (pixmap (xlib:create-pixmap :width 16 :height 16 + :depth 1 :drawable root)) + (gc (xlib:create-gcontext + :drawable pixmap :function boole-1 + :foreground *default-foreground-pixel* + :background *default-background-pixel*))) + (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16) + (xlib:free-gcontext gc) + (values pixmap (xlib:image-x-hot image) (xlib:image-y-hot image)))) + + +;;; Setting up grey borders ... +;;; + +(defparameter hemlock-grey-bitmap-data + '(#*10 #*01)) + +(defun get-hemlock-grey-pixmap (display) + (let* ((screen (xlib:display-default-screen display)) + (depth (xlib:screen-root-depth screen)) + (root (xlib:screen-root screen)) + (height (length hemlock-grey-bitmap-data)) + (width (length (car hemlock-grey-bitmap-data))) + (image (apply #'xlib:bitmap-image hemlock-grey-bitmap-data)) + (pixmap (xlib:create-pixmap :width width :height height + :depth depth :drawable root)) + (gc (xlib:create-gcontext :drawable pixmap + :function boole-1 + :foreground *default-foreground-pixel* + :background *default-background-pixel*))) + (xlib:put-image pixmap gc image + :x 0 :y 0 :width width :height height :bitmap-p t) + (xlib:free-gcontext gc) + pixmap)) + + +;;; Cut Buffer manipulation ... +;;; + +(defun store-cut-string (display string) + (check-type string simple-string) + (setf (xlib:cut-buffer display) string)) + +(defun fetch-cut-string (display) + (xlib:cut-buffer display)) + + +;;; Window naming ... +;;; +(defun set-window-name-for-buffer-name (buffer new-name) + (dolist (ele (buffer-windows buffer)) + (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk ele)) + :icon-name new-name))) + +(defun set-window-name-for-window-buffer (window new-buffer) + (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk window)) + :icon-name (buffer-name new-buffer))) + + + +;;;; Some hacks for supporting Hemlock under Mach. + +;;; WINDOWED-MONITOR-P is used by the reverse video variable's hook function +;;; to determine if it needs to go around fixing all the windows. +;;; +(defun windowed-monitor-p () + "This returns whether the monitor is being used with a window system. It + returns the console's CLX display structure." + *editor-windowed-input*) + +(defun get-terminal-name () + (cdr (assoc :term *environment-list* :test #'eq))) + +(defun get-termcap-env-var () + (cdr (assoc :termcap *environment-list* :test #'eq))) + + + +(defvar *editor-buffer* (make-string 256)) + +;;; GET-EDITOR-TTY-INPUT reads from stream's Unix file descriptor queuing events +;;; in the stream's queue. +;;; +(defun get-editor-tty-input (fd) + (let* ((buf *editor-buffer*) + (len (mach:unix-read fd buf 256)) + (i 0)) + (declare (simple-string buf) (fixnum len i)) + (loop + (when (>= i len) (return t)) + (q-event *real-editor-input* + (translate-tty-char (char-code (schar buf i)))) + (incf i)))) + +;;; This is used to get listening during smart redisplay to pick up input +;;; in between displaying each line by listening longer (or slowing down +;;; line output depending on your model). 10-20 seems to be good for 9600 +;;; baud, and 250 seems to do it with 1200 baud. +;;; +(defparameter listen-iterations-hack 1) ; 10-20 seems to really pick up input. + +(defun editor-tty-listen (stream) + (mach::with-trap-arg-block mach::int1 nc + (dotimes (i listen-iterations-hack nil) + (multiple-value-bind (val err) + (mach::Unix-ioctl (editor-tty-input-stream-fd stream) + mach::FIONREAD + (lisp::alien-value-sap + mach::int1)) + (declare (ignore err)) + (when (and val + (> (alien-access (mach::int1-int (alien-value nc))) 0)) + (return t)))))) + + + +(defvar old-flags) + +(defvar old-tchars) + +(defvar old-ltchars) + +(defun setup-input () + (let ((fd *editor-file-descriptor*)) + (when (mach:unix-isatty 0) + (mach:with-trap-arg-block mach:sgtty sg + (multiple-value-bind + (val err) + (mach:unix-ioctl fd mach:TIOCGETP + (lisp::alien-value-sap mach:sgtty)) + (if (null val) + (error "Could not get tty information, unix error ~S." + (mach:get-unix-error-msg err))) + (let ((flags (alien-access (mach::sgtty-flags (alien-value sg))))) + (setq old-flags flags) + (setf (alien-access (mach::sgtty-flags (alien-value sg))) + (logand (logior flags mach::tty-cbreak) + (lognot mach::tty-echo) + (lognot mach::tty-crmod))) + (multiple-value-bind + (val err) + (mach:unix-ioctl fd mach:TIOCSETP + (lisp::alien-value-sap mach:sgtty)) + (if (null val) + (error "Could not set tty information, unix error ~S." + (mach:get-unix-error-msg err))))))) + (mach:with-trap-arg-block mach:tchars tc + (multiple-value-bind + (val err) + (mach:unix-ioctl fd mach:TIOCGETC + (lisp::alien-value-sap mach:tchars)) + (if (null val) + (error "Could not get tty tchars information, unix error ~S." + (mach:get-unix-error-msg err))) + (setq old-tchars + (vector (alien-access (mach::tchars-intrc (alien-value tc))) + (alien-access (mach::tchars-quitc (alien-value tc))) + (alien-access (mach::tchars-startc (alien-value tc))) + (alien-access (mach::tchars-stopc (alien-value tc))) + (alien-access (mach::tchars-eofc (alien-value tc))) + (alien-access (mach::tchars-brkc (alien-value tc)))))) + (setf (alien-access (mach::tchars-intrc (alien-value tc))) + (if *editor-windowed-input* -1 28)) + (setf (alien-access (mach::tchars-quitc (alien-value tc))) -1) + (setf (alien-access (mach::tchars-startc (alien-value tc))) -1) + (setf (alien-access (mach::tchars-stopc (alien-value tc))) -1) + (setf (alien-access (mach::tchars-eofc (alien-value tc))) -1) + (setf (alien-access (mach::tchars-brkc (alien-value tc))) -1) + (multiple-value-bind + (val err) + (mach:unix-ioctl fd mach:TIOCSETC + (lisp::alien-value-sap mach:tchars)) + (if (null val) (error "Failed to set tchars, unix error ~S." + (mach:get-unix-error-msg err))))) + (mach:with-trap-arg-block mach:ltchars tc + (multiple-value-bind + (val err) + (mach:unix-ioctl fd mach:TIOCGLTC + (lisp::alien-value-sap mach:ltchars)) + (if (null val) + (error "Could not get tty ltchars information, unix error ~S." + (mach:get-unix-error-msg err))) + (setq old-ltchars + (vector (alien-access (mach::ltchars-suspc (alien-value tc))) + (alien-access (mach::ltchars-dsuspc (alien-value tc))) + (alien-access (mach::ltchars-rprntc (alien-value tc))) + (alien-access (mach::ltchars-flushc (alien-value tc))) + (alien-access (mach::ltchars-werasc (alien-value tc))) + (alien-access (mach::ltchars-lnextc (alien-value tc)))))) + (setf (alien-access (mach::ltchars-suspc (alien-value tc))) -1) + (setf (alien-access (mach::ltchars-dsuspc (alien-value tc))) -1) + (setf (alien-access (mach::ltchars-rprntc (alien-value tc))) -1) + (setf (alien-access (mach::ltchars-flushc (alien-value tc))) -1) + (setf (alien-access (mach::ltchars-werasc (alien-value tc))) -1) + (setf (alien-access (mach::ltchars-lnextc (alien-value tc))) -1) + (multiple-value-bind + (val err) + (mach:unix-ioctl fd mach:TIOCSLTC + (lisp::alien-value-sap mach:ltchars)) + (if (null val) (error "Failed to set ltchars, unix error ~S." + (mach:get-unix-error-msg err)))))))) + + +(defun reset-input () + (when (mach:unix-isatty 0) + (if (boundp 'old-flags) + (let ((fd *editor-file-descriptor*)) + (mach:with-trap-arg-block mach:sgtty sg + (multiple-value-bind + (val err) + (mach:unix-ioctl fd mach:TIOCGETP + (lisp::alien-value-sap mach:sgtty)) + (if (null val) + (error "Could not get tty information, unix error ~S." + (mach:get-unix-error-msg err))) + (setf (alien-access (mach::sgtty-flags (alien-value sg))) + old-flags) + (multiple-value-bind + (val err) + (mach:unix-ioctl fd mach:TIOCSETP + (lisp::alien-value-sap mach:sgtty)) + (if (null val) + (error "Could not set tty information, unix error ~S." + (mach:get-unix-error-msg err)))))) + (cond ((and (boundp 'old-tchars) + (simple-vector-p old-tchars) + (eq (length old-tchars) 6)) + (mach:with-trap-arg-block mach:tchars tc + (setf (alien-access (mach::tchars-intrc (alien-value tc))) + (svref old-tchars 0)) + (setf (alien-access (mach::tchars-quitc (alien-value tc))) + (svref old-tchars 1)) + (setf (alien-access (mach::tchars-startc (alien-value tc))) + (svref old-tchars 2)) + (setf (alien-access (mach::tchars-stopc (alien-value tc))) + (svref old-tchars 3)) + (setf (alien-access (mach::tchars-eofc (alien-value tc))) + (svref old-tchars 4)) + (setf (alien-access (mach::tchars-brkc (alien-value tc))) + (svref old-tchars 5)) + (multiple-value-bind + (val err) + (mach:unix-ioctl fd mach:TIOCSETC + (lisp::alien-value-sap mach:tchars)) + (if (null val) + (error "Failed to set tchars, unix error ~S." + (mach:get-unix-error-msg err))))))) + (cond ((and (boundp 'old-ltchars) + (simple-vector-p old-ltchars) + (eq (length old-ltchars) 6)) + (mach:with-trap-arg-block mach:ltchars tc + (setf (alien-access (mach::ltchars-suspc (alien-value tc))) + (svref old-ltchars 0)) + (setf (alien-access (mach::ltchars-dsuspc (alien-value tc))) + (svref old-ltchars 1)) + (setf (alien-access (mach::ltchars-rprntc (alien-value tc))) + (svref old-ltchars 2)) + (setf (alien-access (mach::ltchars-flushc (alien-value tc))) + (svref old-ltchars 3)) + (setf (alien-access (mach::ltchars-werasc (alien-value tc))) + (svref old-ltchars 4)) + (setf (alien-access (mach::ltchars-lnextc (alien-value tc))) + (svref old-ltchars 5)) + (multiple-value-bind + (val err) + (mach:unix-ioctl fd mach:TIOCSLTC + (lisp::alien-value-sap mach:ltchars)) + (if (null val) + (error "Failed to set ltchars, unix error ~S." + (mach:get-unix-error-msg err))))))))))) + + +(defun pause-hemlock () + "Pause hemlock and pop out to the Unix Shell." + (mach:unix-kill (mach:unix-getpid) mach:sigtstp) + T) diff --git a/hemlock/screen.lisp b/hemlock/screen.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a82f122d0b4df965113e00976133a774e80d7ed4 --- /dev/null +++ b/hemlock/screen.lisp @@ -0,0 +1,188 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles. +;;; +;;; Device independent screen management functions. +;;; + +(in-package "HEMLOCK-INTERNALS") + +(export '(make-window delete-window next-window previous-window)) + + + +;;;; Screen management initialization. + +(proclaim '(special *echo-area-buffer*)) + +;;; %INIT-SCREEN-MANAGER creates the initial windows and sets up the data +;;; structures used by the screen manager. The "Main" and "Echo Area" buffer +;;; modelines are set here in case the user modified these Hemlock variables in +;;; his init file. Since these buffers don't have windows yet, these sets +;;; won't cause any updates to occur. This is called from %INIT-REDISPLAY. +;;; +(defun %init-screen-manager (display) + (setf (buffer-modeline-fields *current-buffer*) + (value ed::default-modeline-fields)) + (setf (buffer-modeline-fields *echo-area-buffer*) + (value ed::default-status-line-fields)) + (if (windowed-monitor-p) + (init-bitmap-screen-manager display) + (init-tty-screen-manager (get-terminal-name)))) + + + +;;;; Window operations. + +(defun make-window (start &key + (modelinep t) + (device nil) + window + (font-family *default-font-family*) + (ask-user nil) + x y + (width (value ed::default-window-width)) + (height (value ed::default-window-height))) + "Make a window that displays text starting at the mark Start. + + Modelinep specifies whether the window should display buffer modelines. + + Device is the Hemlock device to make the window on. If it is nil, then + the window is made on the same device as CURRENT-WINDOW. + + Window is an X window to be used for the Hemlock window. If not specified, + we make one by calling the function in *create-window-hook*. This hook maps + the window to the screen. + + Font-Family is the font-family used for displaying text in the window. + + If Ask-User is non-nil, the user is prompted for missing X, Y, Width, and + Height arguments. X and Y are supplied as pixels, but Width and Height are + supplied in characters. Otherwise, the current window's height is halved, + and the new window fills the created space. If halving the current window + results in too small of a window, then a new one is made the same size as + the current, offsetting its vertical placement on the screen some pixels." + + (let* ((device (or device (device-hunk-device (window-hunk (current-window))))) + (window (funcall (device-make-window device) + device start modelinep window font-family + ask-user x y width height))) + (unless window (editor-error "Could not make a window.")) + (invoke-hook ed::make-window-hook window) + window)) + +(defun delete-window (window) + "Make Window go away, removing it from the screen. Uses *delete-window-hook* + to get rid of bitmap window system windows." + (when (eq window *current-window*) + (error "Cannot kill the current window.")) + (invoke-hook ed::delete-window-hook window) + (setq *window-list* (delq window *window-list*)) + (funcall (device-delete-window (device-hunk-device (window-hunk window))) + window)) + +(defun next-window (window) + "Return the next window after Window, wrapping around if Window is the + bottom window." + (check-type window window) + (funcall (device-next-window (device-hunk-device (window-hunk window))) + window)) + +(defun previous-window (window) + "Return the previous window after Window, wrapping around if Window is the + top window." + (check-type window window) + (funcall (device-previous-window (device-hunk-device (window-hunk window))) + window)) + + + +;;;; Random typeout support. + +;;; PREPARE-FOR-RANDOM-TYPEOUT -- Internal +;;; +;;; The WITH-POP-UP-DISPLAY macro calls this just before displaying output +;;; for the user. This goes to some effor to compute the height of the window +;;; in text lines if it is not supplied. Whether it is supplied or not, we +;;; add one to the height for the modeline, and we subtract one line if the +;;; last line is empty. Just before using the height, make sure it is at +;;; least two -- one for the modeline and one for text, so window making +;;; primitives don't puke. +;;; +(defun prepare-for-random-typeout (stream height) + (let* ((buffer (line-buffer (mark-line (random-typeout-stream-mark stream)))) + (real-height (1+ (or height (rt-count-lines buffer)))) + (device (device-hunk-device (window-hunk (current-window))))) + (funcall (device-random-typeout-setup device) device stream + (max (if (and (empty-line-p (buffer-end-mark buffer)) (not height)) + (1- real-height) + real-height) + 2)))) + +;;; RT-COUNT-LINES computes the correct height for a window. This includes +;;; taking wrapping line characters into account. Take the MARK-COLUMN at +;;; the end of each line. This is how many characters long hemlock thinks +;;; the line is. When it is displayed, however, end of line characters are +;;; added to the end of each line that wraps. The second INCF form adds +;;; these to the current line length. Then INCF the current height by the +;;; CEILING of the width of the random typeout window and the line length +;;; (with added line-end chars). Use CEILING because there is always at +;;; least one line. Finally, jump out of the loop if we're at the end of +;;; the buffer. +;;; +(defun rt-count-lines (buffer) + (with-mark ((mark (buffer-start-mark buffer))) + (let ((width (window-width (current-window))) + (count 0)) + (loop + (let* ((column (mark-column (line-end mark))) + (temp (ceiling (incf column (floor (1- column) width)) + width))) + ;; Lines with no characters yield zero temp. + (incf count (if (zerop temp) 1 temp)) + (unless (line-offset mark 1) (return count))))))) + + +;;; RANDOM-TYPEOUT-CLEANUP -- Internal +;;; +;;; Clean up after random typeout. This clears the area where the +;;; random typeout was and redisplays any affected windows. +;;; +(defun random-typeout-cleanup (stream &optional (degree t)) + (let* ((window (random-typeout-stream-window stream)) + (buffer (window-buffer window)) + (device (device-hunk-device (window-hunk window))) + (*more-prompt-action* :normal)) + (update-modeline-field buffer window :more-prompt) + (random-typeout-redisplay window) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer))) + (funcall (device-random-typeout-cleanup device) stream degree) + (when (device-force-output device) + (funcall (device-force-output device))))) + +;;; *more-prompt-action* is bound in random typeout streams before +;;; redisplaying. +;;; +(defvar *more-prompt-action* :normal) +(defvar *random-typeout-ml-fields* + (list (make-modeline-field + :name :more-prompt + :function #'(lambda (buffer window) + (declare (ignore buffer window)) + (ecase *more-prompt-action* + (:more "--More--") + (:flush "--Flush--") + (:empty "") + (:normal + (concatenate 'simple-string + "Random Typeout Buffer [" + (buffer-name buffer) + "]"))))))) diff --git a/hemlock/search1.lisp b/hemlock/search1.lisp new file mode 100644 index 0000000000000000000000000000000000000000..0fe8d11aab0220eb8bd08c085aab4d8f91d71dc0 --- /dev/null +++ b/hemlock/search1.lisp @@ -0,0 +1,649 @@ +;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Searching and replacing functions for Hemlock. +;;; Originally written by Skef Wholey, Rewritten by Rob MacLachlan. +;;; + +(in-package "HEMLOCK-INTERNALS") + +(export '(search-pattern search-pattern-p find-pattern replace-pattern + new-search-pattern)) + + + +;;; The search pattern structure is used only by simple searches, more +;;; complex ones make structures which include it. + +(defstruct (search-pattern (:print-function %print-search-pattern) + (:constructor internal-make-search-pattern)) + kind ; The kind of pattern to search for. + direction ; The direction to search in. + pattern ; The search pattern to use. + search-function ; The function to call to search. + reclaim-function) ; The function to call to reclaim this pattern. + +(setf (documentation 'search-pattern-p 'function) + "Returns true if its argument is a Hemlock search-pattern object, + Nil otherwise.") + +(defun %print-search-pattern (object stream depth) + (let ((*print-level* (and *print-level* (- *print-level* depth))) + (*print-case* :downcase)) + (declare (special *print-level* *print-case*)) + (write-string "#<Hemlock " stream) + (princ (search-pattern-direction object) stream) + (write-char #\space stream) + (princ (search-pattern-kind object) stream) + (write-string " Search-Pattern for ") + (prin1 (search-pattern-pattern object) stream) + (write-char #\> stream) + (terpri stream))) + +(defvar *search-pattern-experts* (make-hash-table :test #'eq) + "Holds an eq hashtable which associates search kinds with the functions + that know how to make patterns of that kind.") +(defvar *search-pattern-documentation* () + "A list of all the kinds of search-pattern that are defined.") + +;;; define-search-kind -- Internal +;;; +;;; This macro is used to define a new kind of search pattern. Kind +;;; is the kind of search pattern to define. Lambda-list is the argument +;;; list for the expert-function to be built and forms it's body. +;;; The arguments passed are the direction, the pattern, and either +;;; an old search-pattern of the same type or nil. Documentation +;;; is put on the search-pattern-documentation property of the kind +;;; keyword. +;;; +(eval-when (compile eval) +(defmacro define-search-kind (kind lambda-list documentation &body forms) + (let ((dummy (gensym))) + `(progn + (push ,documentation *search-pattern-documentation*) + (defun ,dummy () + (setf (gethash ,kind *search-pattern-experts*) + #'(lambda ,lambda-list ,@forms))) + (,dummy)))) +); eval-when (compile eval) + +;;; new-search-pattern -- Public +;;; +;;; This function deallocates any old search-pattern and then dispatches +;;; to the correct expert. +;;; +(defun new-search-pattern (kind direction pattern &optional + result-search-pattern) + "Makes a new Hemlock search pattern of kind Kind to search direction + using Pattern. Direction is either :backward or :forward. + If supplied, result-search-pattern is a pattern to destroy to make + the new one. The variable *search-pattern-documentation* contains + documentation for each kind." + (unless (or (eq direction :forward) (eq direction :backward)) + (error "~S is not a legal search direction." direction)) + (when result-search-pattern + (funcall (search-pattern-reclaim-function result-search-pattern) + result-search-pattern) + (unless (eq kind (search-pattern-kind result-search-pattern)) + (setq result-search-pattern nil))) + (let ((expert (gethash kind *search-pattern-experts*))) + (unless expert + (error "~S is not a defined search pattern kind." kind)) + (funcall expert direction pattern result-search-pattern))) + +;;;; stuff to allocate and de-allocate simple-vectors search-char-code-limit +;;;; in length. + +(defvar *spare-search-vectors* ()) +(eval-when (compile eval) +(defmacro new-search-vector () + `(if *spare-search-vectors* + (pop *spare-search-vectors*) + (make-array search-char-code-limit))) + +(defmacro dispose-search-vector (vec) + `(push ,vec *spare-search-vectors*)) +); eval-when (compile eval) + +;;;; macros used by various search kinds: + +;;; search-once-forward-macro -- Internal +;;; +;;; Passes search-fun strings, starts and lengths to do a forward +;;; search. The other-args are passed through to the searching +;;; function after after everything else The search-fun is +;;; expected to return NIL if nothing is found, or it index where the +;;; match ocurred. Something non-nil is returned if something is +;;; found and line and start are set to where it was found. +;;; +(eval-when (compile eval) +(defmacro search-once-forward-macro (line start search-fun &rest other-args) + `(do* ((l ,line) + (chars (line-chars l) (line-chars l)) + (len (length chars) (length chars)) + (start-pos ,start 0) index) + (()) + (declare (simple-string chars) (fixnum index start-pos len)) + (setq index (,search-fun chars start-pos len ,@other-args)) + (when index + (setq ,start index ,line l) + (return t)) + (setq l (line-next l)) + (when (null l) (return nil)))) + + +;;; search-once-backward-macro -- Internal +;;; +;;; Like search-once-forward-macro, except it goes backwards. Length +;;; is not passed to the search function, since it won't need it. +;;; +(defmacro search-once-backward-macro (line start search-fun &rest other-args) + `(do* ((l ,line) + (chars (line-chars l) (line-chars l)) + (start-pos (1- ,start) (1- (length chars))) index) + (()) + (declare (simple-string chars) (fixnum index start-pos)) + (setq index (,search-fun chars start-pos ,@other-args)) + (when index + (setq ,start index ,line l) + (return t)) + (setq l (line-previous l)) + (when (null l) (return nil)))) +); eval-when (compile eval) + +;;;; String Searches. +;;; +;;; We use the Boyer-Moore algorithm for string searches. +;;; + +;;; sensitive-string-search-macro -- Internal +;;; +;;; This macro does a case-sensitive Boyer-Moore string search. +;;; +;;; Args: +;;; String - The string to search in. +;;; Start - The place to start searching at. +;;; Length - NIL if going backward, the length of String if going forward. +;;; Pattern - A simple-vector of characters. A simple-vector is used +;;; rather than a string because it is believed that simple-vector access +;;; will be faster in most implementations. +;;; Patlen - The length of Pattern. +;;; Last - (1- Patlen) +;;; Jumps - The jump vector as given by compute-boyer-moore-jumps +;;; +/- - The function to increment with, either + (forward) or - +;;; (backward) +;;; -/+ - Like +/-, only the other way around. +(eval-when (compile eval) +(defmacro sensitive-string-search-macro (string start length pattern patlen + last jumps +/- -/+) + `(do ((scan (,+/- ,start ,last)) + (patp ,last)) + (,(if length `(>= scan ,length) '(minusp scan))) + (declare (fixnum scan patp)) + (let ((char (schar ,string scan))) + (cond + ((char= char (svref ,pattern patp)) + (if (zerop patp) + (return scan) + (setq scan (,-/+ scan 1) patp (1- patp)))) + (t + ;; If mismatch consult jump table to find amount to skip. + (let ((jump (svref ,jumps (search-char-code char)))) + (declare (fixnum jump)) + (if (> jump (- ,patlen patp)) + (setq scan (,+/- scan jump)) + (setq scan (,+/- scan (- ,patlen patp))))) + (setq patp ,last)))))) + +;;; insensitive-string-search-macro -- Internal +;;; +;;; This macro is very similar to the case sensitive one, except that +;;; we do the search for a hashed string, and then when we find a match +;;; we compare the uppercased search string with the found string uppercased +;;; and only say we win when they match too. +;;; +(defmacro insensitive-string-search-macro (string start length pattern + folded-string patlen last + jumps +/- -/+) + `(do ((scan (,+/- ,start ,last)) + (patp ,last)) + (,(if length `(>= scan ,length) '(minusp scan))) + (declare (fixnum scan patp)) + (let ((hash (search-hash-code (schar ,string scan)))) + (declare (fixnum hash)) + (cond + ((= hash (the fixnum (svref ,pattern patp))) + (if (zerop patp) + (if (do ((i ,last (1- i))) + (()) + (when (char/= + (search-char-upcase (schar ,string (,+/- scan i))) + (schar ,folded-string i)) + (return nil)) + (when (zerop i) (return t))) + (return scan) + (setq scan (,+/- scan ,patlen) patp ,last)) + (setq scan (,-/+ scan 1) patp (1- patp)))) + (t + ;; If mismatch consult jump table to find amount to skip. + (let ((jump (svref ,jumps hash))) + (declare (fixnum jump)) + (if (> jump (- ,patlen patp)) + (setq scan (,+/- scan jump)) + (setq scan (,+/- scan (- ,patlen patp))))) + (setq patp ,last)))))) + +;;;; Searching for strings with newlines in them: +;;; +;;; Due to the buffer representation, search-strings with embedded +;;; newlines need to be special-cased. What we do is break +;;; the search string up into lines and then searching for a line with +;;; the correct prefix. This is actually a faster search. +;;; For this one we just have one big hairy macro conditionalized for +;;; both case-sensitivity and direction. Have fun!! + +;;; newline-search-macro -- Internal +;;; +;;; Do a search for a string containing newlines. Line is the line +;;; to start on, and Start is the position to start at. Pattern and +;;; optionally Pattern2, are simple-vectors of things that represent +;;; each line in the pattern, and are passed to Test-Fun. Pattern +;;; must contain simple-strings so we can take the length. Test-Fun is a +;;; thing to compare two strings and see if they are equal. Forward-p +;;; tells whether to go forward or backward. +;;; +(defmacro newline-search-macro (line start test-fun pattern forward-p + &optional pattern2) + `(let* ((patlen (length ,pattern)) + (first (svref ,pattern 0)) + (firstlen (length first)) + (l ,line) + (chars (line-chars l)) + (len (length chars)) + ,@(if pattern2 `((other (svref ,pattern2 0))))) + (declare (simple-string first chars) (fixnum firstlen patlen len)) + ,(if forward-p + ;; If doing a forward search, go to the next line if we could not + ;; match due to the start position. + `(when (< (- len ,start) firstlen) + (setq l (line-next l))) + ;; If doing a backward search, go to the previous line if the current + ;; line could not match the last line in the pattern, and then go + ;; back the 1- number of lines in the pattern to avoid a possible + ;; match across the starting point. + `(let ((1-len (1- patlen))) + (declare (fixnum 1-len)) + (when (< ,start (length (the simple-string + (svref ,pattern 1-len)))) + (setq l (line-previous l))) + (dotimes (i 1-len) + (when (null l) (return nil)) + (setq l (line-previous l))))) + (do* () + ((null l)) + (setq chars (line-chars l) len (length chars)) + ;; If the end of this line is the first line in the pattern then check + ;; to see if the other lines match. + (when (and (>= len firstlen) + (,test-fun chars first other + :start1 (- len firstlen) :end1 len + :end2 firstlen)) + (when + (do ((m (line-next l) (line-next m)) + (i 2 (1+ i)) + (next (svref ,pattern 1) (svref ,pattern i)) + ,@(if pattern2 + `((another (svref ,pattern2 1) + (svref ,pattern2 i)))) + len chars nextlen) + ((null m)) + (declare (simple-string next chars) (fixnum len nextlen i)) + (setq chars (line-chars m) nextlen (length next) + len (length chars)) + ;; When on last line of pattern, check if prefix of line. + (when (= i patlen) + (return (and (>= len nextlen) + (,test-fun chars next another :end1 nextlen + :end2 nextlen)))) + (unless (,test-fun chars next another :end1 len + :end2 nextlen) + (return nil))) + (setq ,line l ,start (- len firstlen)) + (return t))) + ;; If not, try the next line + (setq l ,(if forward-p '(line-next l) '(line-previous l)))))) + +;;;; String-comparison macros that are passed to newline-search-macro + +;;; case-sensitive-test-fun -- Internal +;;; +;;; Just thows away the extra arg and calls string=. +;;; +(defmacro case-sensitive-test-fun (string1 string2 ignore &rest keys) + `(string= ,string1 ,string2 ,@keys)) + +;;; case-insensitive-test-fun -- Internal +;;; +;;; First compare the characters hashed with hashed-string2 and then +;;; only if they agree do an actual compare with case-folding. +;;; +(defmacro case-insensitive-test-fun (string1 string2 hashed-string2 + &key end1 (start1 0) end2) + `(when (= (- ,end1 ,start1) ,end2) + (do ((i 0 (1+ i))) + ((= i ,end2) + (dotimes (i ,end2 t) + (when (char/= (search-char-upcase (schar ,string1 (+ ,start1 i))) + (schar ,string2 i)) + (return nil)))) + (when (/= (search-hash-code (schar ,string1 (+ ,start1 i))) + (svref ,hashed-string2 i)) + (return nil))))) +); eval-when (compile eval) + +;;; compute-boyer-moore-jumps -- Internal +;;; +;;; Compute return a jump-vector to do a Boyer-Moore search for +;;; the "string" of things in Vector. Access-fun is a function +;;; that aref's vector and returns a number. +;;; +(defun compute-boyer-moore-jumps (vec access-fun) + (declare (simple-vector vec)) + (let ((jumps (new-search-vector)) + (len (length vec))) + (declare (simple-vector jumps)) + (when (zerop len) (error "Zero length search string not allowed.")) + ;; The default jump is the length of the search string. + (dotimes (i search-char-code-limit) + (setf (aref jumps i) len)) + ;; For chars in the string the jump is the distance from the end. + (dotimes (i len) + (setf (aref jumps (funcall access-fun vec i)) (- len i 1))) + jumps)) + +;;;; Case insensitive searches + +;;; In order to avoid case folding, we do a case-insensitive hash of +;;; each character. We then search for string in this translated +;;; character set, and reject false successes by checking of the found +;;; string is string-equal the the original search string. +;;; + +(defstruct (string-insensitive-search-pattern + (:include search-pattern) + (:conc-name string-insensitive-) + (:print-function %print-search-pattern)) + jumps + hashed-string + folded-string) + +;;; Search-Hash-String -- Internal +;;; +;;; Return a simple-vector containing the search-hash-codes of the +;;; characters in String. +;;; +(defun search-hash-string (string) + (declare (simple-string string)) + (let* ((len (length string)) + (result (make-array len))) + (declare (fixnum len) (simple-vector result)) + (dotimes (i len result) + (setf (aref result i) (search-hash-code (schar string i)))))) + +;;; make-insensitive-newline-pattern -- Internal +;;; +;;; Make bash in fields in a string-insensitive-search-pattern to +;;; do a search for a string with newlines in it. +;;; +(defun make-insensitive-newline-pattern (pattern folded-string) + (declare (simple-string folded-string)) + (let* ((len (length folded-string)) + (num (1+ (count #\newline folded-string :end len))) + (hashed (make-array num)) + (folded (make-array num))) + (declare (simple-vector hashed folded) (fixnum len num)) + (do ((prev 0 nl) + (i 0 (1+ i)) + (nl (position #\newline folded-string :end len) + (position #\newline folded-string :start nl :end len))) + ((null nl) + (let ((piece (subseq folded-string prev len))) + (setf (aref folded i) piece) + (setf (aref hashed i) (search-hash-string piece)))) + (let ((piece (subseq folded-string prev nl))) + (setf (aref folded i) piece) + (setf (aref hashed i) (search-hash-string piece))) + (incf nl)) + (setf (string-insensitive-folded-string pattern) folded + (string-insensitive-hashed-string pattern) hashed))) + +(define-search-kind :string-insensitive (direction pattern old) + ":string-insensitive - Pattern is a string to do a case-insensitive + search for." + (unless old (setq old (make-string-insensitive-search-pattern))) + (setf (search-pattern-kind old) :string-insensitive + (search-pattern-direction old) direction + (search-pattern-pattern old) pattern) + (let* ((folded-string (string-upcase pattern))) + (declare (simple-string folded-string)) + (cond + ((find #\newline folded-string) + (make-insensitive-newline-pattern old folded-string) + (setf (search-pattern-search-function old) + (if (eq direction :forward) + #'insensitive-find-newline-once-forward-method + #'insensitive-find-newline-once-backward-method)) + (setf (search-pattern-reclaim-function old) #'identity)) + (t + (case direction + (:forward + (setf (search-pattern-search-function old) + #'insensitive-find-string-once-forward-method)) + (t + (setf (search-pattern-search-function old) + #'insensitive-find-string-once-backward-method) + (nreverse folded-string))) + (let ((hashed-string (search-hash-string folded-string))) + (setf (string-insensitive-hashed-string old) hashed-string + (string-insensitive-folded-string old) folded-string) + (setf (string-insensitive-jumps old) + (compute-boyer-moore-jumps hashed-string #'svref)) + (setf (search-pattern-reclaim-function old) + #'(lambda (p) + (dispose-search-vector (string-insensitive-jumps p)))))))) + old) + +(defun insensitive-find-string-once-forward-method (pattern line start) + (let* ((hashed-string (string-insensitive-hashed-string pattern)) + (folded-string (string-insensitive-folded-string pattern)) + (jumps (string-insensitive-jumps pattern)) + (patlen (length hashed-string)) + (last (1- patlen))) + (declare (simple-vector jumps hashed-string) (simple-string folded-string) + (fixnum patlen last)) + (when (search-once-forward-macro + line start insensitive-string-search-macro + hashed-string folded-string patlen last jumps + -) + (values line start patlen)))) + +(defun insensitive-find-string-once-backward-method (pattern line start) + (let* ((hashed-string (string-insensitive-hashed-string pattern)) + (folded-string (string-insensitive-folded-string pattern)) + (jumps (string-insensitive-jumps pattern)) + (patlen (length hashed-string)) + (last (1- patlen))) + (declare (simple-vector jumps hashed-string) (simple-string folded-string) + (fixnum patlen last)) + (when (search-once-backward-macro + line start insensitive-string-search-macro + nil hashed-string folded-string patlen last jumps - +) + (values line (- start last) patlen)))) + +(eval-when (compile eval) +(defmacro def-insensitive-newline-search-method (name direction) + `(defun ,name (pattern line start) + (let* ((hashed (string-insensitive-hashed-string pattern)) + (folded-string (string-insensitive-folded-string pattern)) + (patlen (length (the string (search-pattern-pattern pattern))))) + (declare (simple-vector hashed folded-string)) + (when (newline-search-macro line start case-insensitive-test-fun + folded-string ,direction hashed) + (values line start patlen))))) +); eval-when (compile eval) + +(def-insensitive-newline-search-method + insensitive-find-newline-once-forward-method t) +(def-insensitive-newline-search-method + insensitive-find-newline-once-backward-method nil) + +;;;; And Snore, case sensitive. +;;; +;;; This is horribly repetitive, but if I introduce another level of +;;; macroexpansion I will go Insaaaane.... +;;; +(defstruct (string-sensitive-search-pattern + (:include search-pattern) + (:conc-name string-sensitive-) + (:print-function %print-search-pattern)) + string + jumps) + +;;; make-sensitive-newline-pattern -- Internal +;;; +;;; The same, only more sensitive (it hurts when you do that...) +;;; +(defun make-sensitive-newline-pattern (pattern string) + (declare (simple-vector string)) + (let* ((string (coerce string 'simple-string)) + (len (length string)) + (num (1+ (count #\newline string :end len))) + (sliced (make-array num))) + (declare (simple-string string) (simple-vector sliced) (fixnum len num)) + (do ((prev 0 nl) + (i 0 (1+ i)) + (nl (position #\newline string :end len) + (position #\newline string :start nl :end len))) + ((null nl) + (setf (aref sliced i) (subseq string prev len))) + (setf (aref sliced i) (subseq string prev nl)) + (incf nl)) + (setf (string-sensitive-string pattern) sliced))) + +(define-search-kind :string-sensitive (direction pattern old) + ":string-sensitive - Pattern is a string to do a case-sensitive + search for." + (unless old (setq old (make-string-sensitive-search-pattern))) + (setf (search-pattern-kind old) :string-sensitive + (search-pattern-direction old) direction + (search-pattern-pattern old) pattern) + (let* ((string (coerce pattern 'simple-vector))) + (declare (simple-vector string)) + (cond + ((find #\newline string) + (make-sensitive-newline-pattern old string) + (setf (search-pattern-search-function old) + (if (eq direction :forward) + #'sensitive-find-newline-once-forward-method + #'sensitive-find-newline-once-backward-method)) + (setf (search-pattern-reclaim-function old) #'identity)) + (t + (case direction + (:forward + (setf (search-pattern-search-function old) + #'sensitive-find-string-once-forward-method)) + (t + (setf (search-pattern-search-function old) + #'sensitive-find-string-once-backward-method) + (nreverse string))) + (setf (string-sensitive-string old) string) + (setf (string-sensitive-jumps old) + (compute-boyer-moore-jumps + string #'(lambda (v i) (char-code (svref v i))))) + (setf (search-pattern-reclaim-function old) + #'(lambda (p) + (dispose-search-vector (string-sensitive-jumps p))))))) + old) + +(defun sensitive-find-string-once-forward-method (pattern line start) + (let* ((string (string-sensitive-string pattern)) + (jumps (string-sensitive-jumps pattern)) + (patlen (length string)) + (last (1- patlen))) + (declare (simple-vector jumps string) (fixnum patlen last)) + (when (search-once-forward-macro + line start sensitive-string-search-macro + string patlen last jumps + -) + (values line start patlen)))) + +(defun sensitive-find-string-once-backward-method (pattern line start) + (let* ((string (string-sensitive-string pattern)) + (jumps (string-sensitive-jumps pattern)) + (patlen (length string)) + (last (1- patlen))) + (declare (simple-vector jumps string) (fixnum patlen last)) + (when (search-once-backward-macro + line start sensitive-string-search-macro + nil string patlen last jumps - +) + (values line (- start last) patlen)))) + +(eval-when (compile eval) +(defmacro def-sensitive-newline-search-method (name direction) + `(defun ,name (pattern line start) + (let* ((string (string-sensitive-string pattern)) + (patlen (length (the string (search-pattern-pattern pattern))))) + (declare (simple-vector string)) + (when (newline-search-macro line start case-sensitive-test-fun + string ,direction) + (values line start patlen))))) +); eval-when (compile eval) + +(def-sensitive-newline-search-method + sensitive-find-newline-once-forward-method t) +(def-sensitive-newline-search-method + sensitive-find-newline-once-backward-method nil) + +(defun find-pattern (mark search-pattern) + "Find a match of Search-Pattern starting at Mark. Mark is moved to + point before the match and the number of characters matched is returned. + If there is no match for the pattern then Mark is not modified and NIL + is returned." + (close-line) + (multiple-value-bind (line start matched) + (funcall (search-pattern-search-function search-pattern) + search-pattern (mark-line mark) + (mark-charpos mark)) + (when matched + (move-to-position mark start line) + matched))) + +;;; replace-pattern -- Public +;;; +;;; +(defun replace-pattern (mark search-pattern replacement &optional n) + "Replaces N occurrences of the Search-Pattern with the Replacement string + in the text starting at the given Mark. If N is Nil, all occurrences + following the Mark are replaced." + (close-line) + (do* ((replacement (coerce replacement 'simple-string)) + (new (length (the simple-string replacement))) + (fun (search-pattern-search-function search-pattern)) + (forward-p (eq (search-pattern-direction search-pattern) :forward)) + (n (if n (1- n) -1) (1- n)) + (m (copy-mark mark :temporary)) line start matched) + (()) + (multiple-value-setq (line start matched) + (funcall fun search-pattern (mark-line m) (mark-charpos m))) + (unless matched (return m)) + (setf (mark-line m) line (mark-charpos m) start) + (delete-characters m matched) + (insert-string m replacement) + (when forward-p (character-offset m new)) + (when (zerop n) (return m)) + (close-line))) diff --git a/hemlock/shell.lisp b/hemlock/shell.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3d79ff505f6c4f291d256eaf92653140f90e10a9 --- /dev/null +++ b/hemlock/shell.lisp @@ -0,0 +1,329 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Hemlock command level support for processes. +;;; +;;; Written by Blaine Burks. +;;; + +(in-package "HEMLOCK") + + +(defun setup-process-buffer (buffer) + (let ((mark (copy-mark (buffer-point buffer) :right-inserting))) + (defhvar "Buffer Input Mark" + "The buffer input mark for this buffer." + :buffer buffer + :value mark) + (defhvar "Process Output Stream" + "The process structure for this buffer." + :buffer buffer + :value (make-hemlock-output-stream mark)) + (defhvar "Interactive History" + "A ring of the regions input to an interactive mode (Eval or Typescript)." + :buffer buffer + :value (make-ring (value interactive-history-length))) + (defhvar "Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (defhvar "Searching Interactive Pointer" + "Pointer into \"Interactive History\"." + :buffer buffer + :value 0) + (unless (buffer-modeline-field-p buffer :process-status) + (setf (buffer-modeline-fields buffer) + (nconc (buffer-modeline-fields buffer) + (list (modeline-field :process-status))))))) + +(defmode "Process" :major-p nil :setup-function #'setup-process-buffer) + + +;;;; Support for handling input before the prompt in process buffers. + +(defun unwedge-process-buffer () + (buffer-end (current-point)) + (deliver-signal-to-process :SIGINT (value process)) + (editor-error "Aborted.")) + +(defhvar "Unwedge Interactive Input Fun" + "Function to call when input is confirmed, but the point is not past the + input mark." + :value #'unwedge-process-buffer + :mode "Process") + +(defhvar "Unwedge Interactive Input String" + "String to add to \"Point not past input mark. \" explaining what will + happen if the the user chooses to be unwedged." + :value "Interrupt and throw to end of buffer?" + :mode "Process") + + +;;;; Some Global Variables. + +(defhvar "Current Shell" + "The shell that \"Select Shell\" will zap you to.") + +(defhvar "Kill Process Confirm" + "When non-nil, ask the user whether he really wants to blow away the shell. ~ + Otherwise, just blow it away." + :value T) + +(defhvar "Shell Utility" + "The shell command uses this as the default command line." + :value "/bin/csh") + +(defhvar "Shell Utility Switches" + "This is list of strings that are the default command line arguments to the + utility in \"Shell Utility\"." + :value nil) + + + +;;;; The Shell and New Shell Commands. + +(defcommand "Shell" (p) + "If a shell buffer exists, pop to it. Otherwise creates a new one and pop to + it. With an argument, prompt for a command and buffer to execute it in." + "If a shell buffer exists, pop to it. Otherwise creates a new one and pop to + it. With an argument, prompt for a command and buffer to execute it in." + (let ((shell (value current-shell))) + (if shell (change-to-buffer shell) (make-new-shell p)))) + +(defcommand "New Shell" (p) + "Creates a new shell and puts you in it." + "Creates a new shell and puts you in it." + (make-new-shell p)) + +(defun make-new-shell (prompt-for-command-p + &optional (command-line (get-command-line) clp)) + (let* ((command (or (and clp command-line) + (if prompt-for-command-p + (prompt-for-string + :default command-line :trim t + :prompt "Command to execute: " + :help "Shell command line to execute.") + command-line))) + (buffer-name (if prompt-for-command-p + (prompt-for-string + :default + (concatenate 'simple-string command " process") + :trim t + :prompt `("Buffer in which to execute ~A? " + ,command) + :help "Where output from this process will appear.") + (new-shell-name))) + (buffer (make-buffer + buffer-name + :modes '("Fundamental" "Process") + :delete-hook + (list #'(lambda (buffer) + (when (eq (value current-shell) buffer) + (setf (value current-shell) nil)) + (kill-process (variable-value 'process + :buffer buffer))))))) + (unless buffer + (setf buffer (getstring buffer-name *buffer-names*)) + (buffer-end (buffer-point buffer))) + (defhvar "Process" + "The process for Shell and Process buffers." + :buffer buffer + :value (ext::run-program "/bin/sh" (list "-c" command) + :wait nil + :pty (variable-value 'process-output-stream + :buffer buffer) + :env (frob-environment-list + (car (buffer-windows buffer))) + :status-hook #'(lambda (process) + (declare (ignore process)) + (update-process-buffer buffer)) + :input t :output t)) + (update-process-buffer buffer) + (unless (value current-shell) + (setf (value current-shell) buffer)) + (change-to-buffer buffer))) + +;;; GET-COMMAND-LINE -- Internal. +;;; +;;; This just conses up a string to feed to the shell. +;;; +(defun get-command-line () + (concatenate 'simple-string (value shell-utility) " " + (value shell-utility-switches))) + +;;; FROB-ENVIRONMENT-LIST -- Internal. +;;; +;;; This sets some environment variables so the shell will be in the proper +;;; state when it comes up. +;;; +(defun frob-environment-list (window) + (list* (cons :termcap (concatenate 'simple-string + "emacs:co#" + (if window + (lisp::quick-integer-to-string + (window-width window)) + "") + ":tc=unkown:")) + (cons :emacs "t") (cons :term "emacs") + (remove-if #'(lambda (keyword) + (member keyword '(:termcap :emacs :term) + :test #'(lambda (cons keyword) + (eql (car cons) keyword)))) + ext:*environment-list*))) + +;;; NEW-SHELL-NAME -- Internal. +;;; +;;; This returns a unique buffer name for a shell by incrementing the value of +;;; *process-number* until "Process <*process-number*> is not already the name +;;; of a buffer. Perhaps this is being overly cautious, but I've seen some +;;; really stupid users. +;;; +(defvar *process-number* 0) +;;; +(defun new-shell-name () + (loop + (let ((buffer-name (format nil "Shell ~D" (incf *process-number*)))) + (unless (getstring buffer-name *buffer-names*) (return buffer-name))))) + + +;;;; Modeline support. + +(defun modeline-process-status (buffer window) + (declare (ignore window)) + (when (hemlock-bound-p 'process :buffer buffer) + (let ((process (variable-value 'process :buffer buffer))) + (ecase (ext:process-status process) + (:running "running") + (:stopped "stopped") + (:signaled "killed by signal ~D" (mach:unix-signal-name + (ext:process-exit-code process))) + (:exited (format nil "exited with status ~D" + (ext:process-exit-code process))))))) + + +(make-modeline-field :name :process-status + :function #'modeline-process-status) + +(defun update-process-buffer (buffer) + (when (buffer-modeline-field-p buffer :process-status) + (dolist (window (buffer-windows buffer)) + (update-modeline-field buffer window :process-status))) + (let ((process (variable-value 'process :buffer buffer))) + (unless (ext:process-alive-p process) + (ext:process-close process) + (setf (value current-shell) nil)))) + + +;;;; Supporting Commands. + +(defcommand "Confirm Process Input" (p) + "Evaluate Process Mode input between the point and last prompt." + "Evaluate Process Mode input between the point and last prompt." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (let* ((process (value process)) + (stream (ext:process-pty process))) + (case (ext:process-status process) + (:running) + (:stopped (editor-error "The process has been stopped.")) + (t (editor-error "The process is dead."))) + (let ((input-region (get-interactive-input))) + (write-line (region-to-string input-region) stream) + (force-output (ext:process-pty process)) + (insert-character (current-point) #\newline) + ;; Move "Buffer Input Mark" to end of buffer. + (move-mark (region-start input-region) (region-end input-region))))) + +(defcommand "Kill Main Process" (p) + "Kills the process in the current buffer." + "Kills the process in the current buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (when (or (not (value kill-process-confirm)) + (prompt-for-y-or-n :default nil + :prompt "Really blow away shell? " + :default nil + :default-string "no")) + (kill-process (value process)))) + +(defcommand "Stop Main Process" (p) + "Stops the process in the current buffer. With an argument use :SIGSTOP + instead of :SIGTSTP." + "Stops the process in the current buffer. With an argument use :SIGSTOP + instead of :SIGTSTP." + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-process (if p :SIGSTOP :SIGTSTP) (value process))) + +(defcommand "Continue Main Process" (p) + "Continues the process in the current buffer." + "Continues the process in the current buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-process :SIGCONT (value process))) + +(defun kill-process (process) + "Self-explanatory." + (deliver-signal-to-process :SIGKILL process)) + +(defun deliver-signal-to-process (signal process) + "Delivers a signal to a process." + (ext:process-kill process signal :process-group)) + +(defcommand "Send EOF to Process" (p) + "Sends a Ctrl-D to the process in the current buffer." + "Sends a Ctrl-D to the process in the current buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (let ((stream (ext:process-pty (value process)))) + (write-char (int-char 4) stream) + (force-output stream))) + +(defcommand "Interrupt Buffer Subprocess" (p) + "Stop the subprocess currently executing in this shell." + "Stop the subprocess currently executing in this shell." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (buffer-end (current-point)) + (buffer-end (value buffer-input-mark)) + (deliver-signal-to-subprocess :SIGINT (value process))) + +(defcommand "Kill Buffer Subprocess" (p) + "Kill the subprocess currently executing in this shell." + "Kill the subprocess currently executing in this shell." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-subprocess :SIGKILL (value process))) + +(defcommand "Quit Buffer Subprocess" (p) + "Quit the subprocess currently executing int his shell." + "Quit the subprocess currently executing int his shell." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-subprocess :SIGQUIT (value process))) + +(defcommand "Stop Buffer Subprocess" (p) + "Stop the subprocess currently executing in this shell." + "Stop the subprocess currently executing in this shell." + (declare (ignore p)) + (unless (hemlock-bound-p 'process :buffer (current-buffer)) + (editor-error "Not in a process buffer.")) + (deliver-signal-to-subprocess (if p :SIGSTOP :SIGTSTP) (value process))) + +(defun deliver-signal-to-subprocess (signal process) + "Delivers a signal to a subprocess of a shell." + (ext:process-kill process signal :pty-process-group)) diff --git a/hemlock/spell-aug.lisp b/hemlock/spell-aug.lisp new file mode 100644 index 0000000000000000000000000000000000000000..32b5d19f14e785ff292ef345191fd0fe05fa5603 --- /dev/null +++ b/hemlock/spell-aug.lisp @@ -0,0 +1,235 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; +;;; This file contains the code to grow the spelling dictionary in system +;;; space by reading a text file of entries or adding one at a time. This +;;; code relies on implementation dependent code found in Spell-RT.Lisp. + + +(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM")) + +(export '(spell-add-entry spell-read-dictionary spell-remove-entry + spell-root-flags)) + + + +;;;; Converting Flags to Masks + +(defconstant flag-names-to-masks + `((#\V . ,V-mask) (#\N . ,N-mask) (#\X . ,X-mask) + (#\H . ,H-mask) (#\Y . ,Y-mask) (#\G . ,G-mask) + (#\J . ,J-mask) (#\D . ,D-mask) (#\T . ,T-mask) + (#\R . ,R-mask) (#\Z . ,Z-mask) (#\S . ,S-mask) + (#\P . ,P-mask) (#\M . ,M-mask))) + +(defvar *flag-masks* + (make-array 128 :element-type '(unsigned-byte 16) :initial-element 0) + "This holds the masks for character flags, which is used when reading + a text file of dictionary words. Illegal character flags hold zero.") + +(eval-when (compile eval) +(defmacro flag-mask (char) + `(aref *flag-masks* (char-code ,char))) +) ;eval-when + +(dolist (e flag-names-to-masks) + (let ((char (car e)) + (mask (cdr e))) + (setf (flag-mask char) mask) + (setf (flag-mask (char-downcase char)) mask))) + + + +;;;; String and Hashing Macros + +(eval-when (compile eval) + +(defmacro string-table-replace (src-string dst-start length) + `(sap-replace *string-table* ,src-string 0 ,dst-start (+ ,dst-start ,length))) + +;;; HASH-ENTRY is used in SPELL-ADD-ENTRY to find a dictionary location for +;;; adding a new entry. If a location contains a zero, then it has never +;;; been used, and no entries have ever been "hashed past" it. If a location +;;; contains a -1, then it once contained an entry that has since been +;;; deleted. +;;; +(defmacro hash-entry (entry entry-len) + (let ((loop-loc (gensym)) (loc-contents (gensym)) + (hash (gensym)) (loc (gensym))) + `(let* ((,hash (string-hash ,entry ,entry-len)) + (,loc (rem ,hash (the fixnum *dictionary-size*))) + (,loc-contents (dictionary-ref ,loc))) + (declare (fixnum ,loc ,loc-contents)) + (if (or (zerop ,loc-contents) (= ,loc-contents -1)) + ,loc + (hash2-loop (,loop-loc ,loc-contents) ,loc ,hash + ,loop-loc nil t))))) + +) ;eval-when + + + +;;;; Top Level Stuff + +(defun spell-read-dictionary (filename) + "Add entries to dictionary from lines in the file filename." + (with-open-file (s filename :direction :input) + (loop (multiple-value-bind (entry eofp) (read-line s nil nil) + (declare (simple-string entry)) + (unless entry (return)) + (spell-add-entry entry) + (if eofp (return)))))) + + +;;; This is used to break up an 18 bit string table index into two parts +;;; for storage in a word descriptor unit. See the documentation at the +;;; top of Spell-Correct.Lisp. +;;; +(defconstant whole-index-low-byte (byte 16 0)) + +(defun spell-add-entry (line &optional + (word-end (or (position #\/ line :test #'char=) + (length line)))) + "Line is of the form \"entry/flag1/flag2\" or \"entry\". It is parsed and + added to the spelling dictionary. Line is desstructively modified." + (declare (simple-string line) (fixnum word-end)) + (nstring-upcase line :end word-end) + (when (> word-end max-entry-length) + (return-from spell-add-entry nil)) + (let ((entry (lookup-entry line word-end))) + (when entry + (add-flags (+ entry 2) line word-end) + (return-from spell-add-entry nil))) + (let* ((hash-loc (hash-entry line word-end)) + (string-ptr *string-table-size*) + (desc-ptr *descriptors-size*) + (desc-ptr+1 (1+ desc-ptr)) + (desc-ptr+2 (1+ desc-ptr+1))) + (declare (fixnum string-ptr)) + (when (not hash-loc) (error "Dictionary Overflow!")) + (when (> 3 *free-descriptor-elements*) (grow-descriptors)) + (when (> word-end *free-string-table-bytes*) (grow-string-table)) + (decf *free-descriptor-elements* 3) + (incf *descriptors-size* 3) + (decf *free-string-table-bytes* word-end) + (incf *string-table-size* word-end) + (setf (dictionary-ref hash-loc) desc-ptr) + (setf (descriptor-ref desc-ptr) + (dpb (the fixnum (ldb new-hash-byte (string-hash line word-end))) + stored-hash-byte + word-end)) + (setf (descriptor-ref desc-ptr+1) + (ldb whole-index-low-byte string-ptr)) + (setf (descriptor-ref desc-ptr+2) + (dpb (the fixnum (ldb whole-index-high-byte string-ptr)) + stored-index-high-byte + 0)) + (add-flags desc-ptr+2 line word-end) + (string-table-replace line string-ptr word-end)) + t) + +(defun add-flags (loc line word-end) + (declare (simple-string line) (fixnum word-end)) + (do ((flag (1+ word-end) (+ 2 flag)) + (line-end (length line))) + ((>= flag line-end)) + (declare (fixnum flag line-end)) + (let ((flag-mask (flag-mask (schar line flag)))) + (declare (fixnum flag-mask)) + (unless (zerop flag-mask) + (setf (descriptor-ref loc) + (logior flag-mask (descriptor-ref loc))))))) + +;;; SPELL-REMOVE-ENTRY destructively uppercases entry in removing it from +;;; the dictionary. First entry is looked up, and if it is found due to a +;;; flag, the flag is cleared in the descriptor table. If entry is a root +;;; word in the dictionary (that is, looked up without the use of a flag), +;;; then the root and all its derivitives are deleted by setting its +;;; dictionary location to -1. +;;; +(defun spell-remove-entry (entry) + "Removes entry from the dictionary, so it will be an unknown word. Entry + is a simple string and is destructively modified. If entry is a root + word, then all words derived with entry and its flags will also be deleted." + (declare (simple-string entry)) + (nstring-upcase entry) + (let ((entry-len (length entry))) + (declare (fixnum entry-len)) + (when (<= 2 entry-len max-entry-length) + (multiple-value-bind (index flagp) + (spell-try-word entry entry-len) + (when index + (if flagp + (setf (descriptor-ref (+ 2 index)) + (logandc2 (descriptor-ref (+ 2 index)) flagp)) + (let* ((hash (string-hash entry entry-len)) + (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) + stored-hash-byte + (the fixnum entry-len))) + (loc (rem hash (the fixnum *dictionary-size*))) + (loc-contents (dictionary-ref loc))) + (declare (fixnum hash hash-and-len loc)) + (cond ((zerop loc-contents) nil) + ((found-entry-p loc-contents entry entry-len hash-and-len) + (setf (dictionary-ref loc) -1)) + (t + (hash2-loop (loop-loc loc-contents) loc hash + nil + (when (found-entry-p loc-contents entry + entry-len hash-and-len) + (setf (dictionary-ref loop-loc) -1) + (return -1)))))))))))) + +(defun spell-root-flags (index) + "Return the flags associated with the root word corresponding to a + dictionary entry at index." + (let ((desc-word (descriptor-ref (+ 2 index))) + (result ())) + (declare (fixnum desc-word)) + (dolist (ele flag-names-to-masks result) + (unless (zerop (logand (the fixnum (cdr ele)) desc-word)) + (push (car ele) result))))) + + + +;;;; Growing Dictionary Structures + +;;; GROW-DESCRIPTORS grows the descriptors vector by 10%. +;;; +(defun grow-descriptors () + (let* ((old-size (+ (the fixnum *descriptors-size*) + (the fixnum *free-descriptor-elements*))) + (new-size (truncate (* old-size 1.1))) + (new-bytes (* new-size 2)) + (new-sap (allocate-bytes new-bytes))) + (declare (fixnum new-size old-size)) + (sap-replace new-sap *descriptors* 0 0 + (* 2 (the fixnum *descriptors-size*))) + (deallocate-bytes (system-address *descriptors*) (* 2 old-size)) + (setf *free-descriptor-elements* + (- new-size (the fixnum *descriptors-size*))) + (setf *descriptors* new-sap))) + +;;; GROW-STRING-TABLE grows the string table by 10%. +;;; +(defun grow-string-table () + (let* ((old-size (+ (the fixnum *string-table-size*) + (the fixnum *free-string-table-bytes*))) + (new-size (truncate (* old-size 1.1))) + (new-sap (allocate-bytes new-size))) + (declare (fixnum new-size old-size)) + (sap-replace new-sap *string-table* 0 0 *string-table-size*) + (setf *free-string-table-bytes* + (- new-size (the fixnum *string-table-size*))) + (deallocate-bytes (system-address *string-table*) old-size) + (setf *string-table* new-sap))) diff --git a/hemlock/spell-build.lisp b/hemlock/spell-build.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b8fb29a446fdcffecd25e82b2c8b959600328d3e --- /dev/null +++ b/hemlock/spell-build.lisp @@ -0,0 +1,242 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; + +;;; This file contains code to build a new binary dictionary file from +;;; text in system space. This code relies on implementation dependent +;;; code from spell-rt.lisp. Also, it is expected that spell-corr.lisp +;;; and spell-aug.lisp have been loaded. In order to compile this file, +;;; you must first compile spell-rt, spell-corr.lisp, and spell-aug.lisp. + +;;; The text file must be in the following format: +;;; entry1/flag1/flag2/flag3 +;;; entry2 +;;; entry3/flag1/flag2/flag3/flag4/flag5. +;;; The flags are single letter indicators of legal suffixes for the entry; +;;; the available flags and their correct use may be found at the beginning +;;; of spell-corr.lisp in the Hemlock sources. There must be exactly one +;;; entry per line, and each line must be flushleft. + +;;; The dictionary is built in system space as three distinct +;;; blocks of memory: the dictionary which is a hash table whose elements +;;; are one machine word or of type '(unsigned-byte 16); a descriptors +;;; vector which is described below; and a string table. After all the +;;; entries are read in from the text file, one large block of memory is +;;; validated, and the three structures are moved into it. Then the file +;;; is written. When the large block of memory is validated, enough +;;; memory is allocated to write the three vector such that they are page +;;; aligned. This is important for the speed it allows in growing the +;;; "dictionary" when augmenting it from a user's text file (see +;;; spell-aug.lisp). + + +(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM")) + + + +;;;; Constants + +;;; This is an upper bound estimate of the number of stored entries in the +;;; dictionary. It should not be more than 21,845 because the dictionary +;;; is a vector of type '(unsigned-byte 16), and the descriptors' vector +;;; for the entries uses three '(unsigned-byte 16) elements per descriptor +;;; unit. See the beginning of Spell-Correct.Lisp. +;;; +(defconstant max-entry-count-estimate 15600) + +(defconstant new-dictionary-size 20011) + +(defconstant new-descriptors-size (1+ (* 3 max-entry-count-estimate))) + +(defconstant max-string-table-length (* 10 max-entry-count-estimate)) + + + +;;;; Hashing + +;;; These hashing macros are different from the ones in Spell-Correct.Lisp +;;; simply because we are using separate space and global specials/constants. +;;; Of course, they should be identical, but it doesn't seem worth cluttering +;;; up Spell-Correct with macro generating macros for this file. + +(eval-when (compile eval) + +(defmacro new-hash2-increment (hash) + `(- new-dictionary-size + 2 + (the fixnum (rem ,hash (- new-dictionary-size 2))))) + +(defmacro new-hash2-loop (loc hash dictionary) + (let ((incr (gensym)) + (loop-loc (gensym))) + `(let* ((,incr (new-hash2-increment ,hash)) + (,loop-loc ,loc)) + (declare (fixnum ,incr ,loop-loc)) + (loop (setf ,loop-loc + (rem (+ ,loop-loc ,incr) new-dictionary-size)) + (when (zerop (the fixnum (aref ,dictionary ,loop-loc))) + (return ,loop-loc)) + (when (= ,loop-loc ,loc) (return nil)))))) + +(defmacro new-hash-entry (entry entry-len dictionary) + (let ((hash (gensym)) + (loc (gensym))) + `(let* ((,hash (string-hash ,entry ,entry-len)) + (,loc (rem ,hash new-dictionary-size))) + (declare (fixnum ,loc)) + (cond ((not (zerop (the fixnum (aref ,dictionary ,loc)))) + (incf *collision-count*) + (new-hash2-loop ,loc ,hash ,dictionary)) + (t ,loc))))) + +) ;eval-when + + + +;;;; Build-Dictionary + +;;; An interesting value when building an initial dictionary. +(defvar *collision-count* 0) + +(defvar *new-dictionary*) +(defvar *new-descriptors*) +(defvar *new-string-table*) + +(defun build-dictionary (input output &optional save-structures-p) + (let ((dictionary (make-array new-dictionary-size + :element-type '(unsigned-byte 16))) + (descriptors (make-array new-descriptors-size + :element-type '(unsigned-byte 16))) + (string-table (make-string max-string-table-length))) + (write-line "Reading dictionary ...") + (force-output) + (setf *collision-count* 0) + (multiple-value-bind (entry-count string-table-length) + (read-initial-dictionary input dictionary + descriptors string-table) + (write-line "Writing dictionary ...") + (force-output) + (write-dictionary output dictionary descriptors entry-count + string-table string-table-length) + (when save-structures-p + (setf *new-dictionary* dictionary) + (setf *new-descriptors* descriptors) + (setf *new-string-table* string-table)) + (format t "~D entries processed with ~D collisions." + entry-count *collision-count*)))) + +(defun read-initial-dictionary (f dictionary descriptors string-table) + (let* ((filename (pathname f)) + (s (open filename :direction :input :if-does-not-exist nil))) + (unless s (error "File ~S does not exist." f)) + (multiple-value-prog1 + (let ((descriptor-ptr 1) + (string-ptr 0) + (entry-count 0)) + (declare (fixnum descriptor-ptr string-ptr entry-count)) + (loop (multiple-value-bind (line eofp) (read-line s nil nil) + (declare (simple-string line)) + (unless line (return (values entry-count string-ptr))) + (incf entry-count) + (when (> entry-count max-entry-count-estimate) + (error "There are too many entries in text file!~%~ + Please change constants in spell-build.lisp, ~ + recompile the file, and reload it.~%~ + Be sure to understand the constraints of permissible ~ + values.")) + (let ((flags (or (position #\/ line :test #'char=) (length line)))) + (declare (fixnum flags)) + (cond ((> flags max-entry-length) + (format t "Entry ~s too long." (subseq line 0 flags)) + (force-output)) + (t (let ((new-string-ptr (+ string-ptr flags))) + (declare (fixnum new-string-ptr)) + (when (> new-string-ptr max-string-table-length) + (error "Spell string table overflow!~%~ + Please change constants in ~ + spell-build.lisp, recompile the file, ~ + and reload it.~%~ + Be sure to understand the constraints ~ + of permissible values.")) + (spell-place-entry line flags + dictionary descriptors string-table + descriptor-ptr string-ptr) + (incf descriptor-ptr 3) + (setf string-ptr new-string-ptr))))) + (when eofp (return (values entry-count string-ptr)))))) + (close s)))) + +(defun spell-place-entry (line word-end dictionary descriptors string-table + descriptor-ptr string-ptr) + (declare (simple-string line string-table) + (fixnum word-end descriptor-ptr string-ptr) + (type (array (unsigned-byte 16) 1) dictionary descriptors)) + (nstring-upcase line :end word-end) + (let* ((hash-loc (new-hash-entry line word-end dictionary)) + (descriptor-ptr+1 (1+ descriptor-ptr)) + (descriptor-ptr+2 (1+ descriptor-ptr+1))) + (unless hash-loc (error "Dictionary Overflow!")) + (setf (aref dictionary hash-loc) descriptor-ptr) + (setf (aref descriptors descriptor-ptr) + (dpb (the fixnum + (ldb new-hash-byte (string-hash line word-end))) + stored-hash-byte + word-end)) + (setf (aref descriptors descriptor-ptr+1) + (ldb whole-index-low-byte string-ptr)) + (setf (aref descriptors descriptor-ptr+2) + (dpb (the fixnum (ldb whole-index-high-byte string-ptr)) + stored-index-high-byte + 0)) + (new-add-flags descriptors descriptor-ptr+2 line word-end) + (replace string-table line :start1 string-ptr :end2 word-end))) + +(defun new-add-flags (descriptors loc line word-end) + (declare (simple-string line) + (fixnum word-end) + (type (array (unsigned-byte 16) 1) descriptors)) + (do ((flag (1+ word-end) (+ 2 flag)) + (line-end (length line))) + ((>= flag line-end)) + (declare (fixnum flag line-end)) + (let ((flag-mask (flag-mask (schar line flag)))) + (declare (fixnum flag-mask)) + (if (zerop flag-mask) + (format t "Illegal flag ~S on word ~S." + (schar line flag) (subseq line 0 word-end)) + (setf (aref descriptors loc) + (logior flag-mask (aref descriptors loc))))))) + +(defun write-dictionary (f dictionary descriptors entry-count + string-table string-table-length) + (declare (type (array (unsigned-byte 16) 1) dictionary descriptors) + (simple-string string-table) + (fixnum string-table-length)) + (let ((filename (lisp::predict-name (namestring (pathname f)) nil))) + (with-open-file (s filename :direction :output + :element-type '(unsigned-byte 16) + :if-exists :overwrite + :if-does-not-exist :create) + (let ((descriptors-size (1+ (* 3 entry-count)))) + (write-byte magic-file-id s) + (write-byte new-dictionary-size s) + (write-byte descriptors-size s) + (write-byte (ldb whole-index-low-byte string-table-length) s) + (write-byte (ldb whole-index-high-byte string-table-length) s) + (dotimes (i new-dictionary-size) + (write-byte (aref dictionary i) s)) + (dotimes (i descriptors-size) + (write-byte (aref descriptors i) s)))) + (with-open-file (s f :direction :output :element-type 'string-char + :if-exists :append) + (write-string string-table s :end string-table-length)))) diff --git a/hemlock/spell-corr.lisp b/hemlock/spell-corr.lisp new file mode 100644 index 0000000000000000000000000000000000000000..63f740588337af4a7f85f5e6a7f160c9381978b4 --- /dev/null +++ b/hemlock/spell-corr.lisp @@ -0,0 +1,804 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; Designed by Bill Chiles and Rob Maclachlan +;;; + +;;; This is the file that deals with checking and correcting words +;;; using a dictionary read in from a binary file. It has been written +;;; from the basic ideas used in Ispell (on DEC-20's) which originated as +;;; Spell on the ITS machines at MIT. There are flags which have proper +;;; uses defined for them that indicate permissible suffixes to entries. +;;; This allows for about three times as many known words than are actually +;;; stored. When checking the spelling of a word, first it is looked up; +;;; if this fails, then possible roots are looked up, and if any has the +;;; appropriate suffix flag, then the word is considered to be correctly +;;; spelled. For an unknown word, the following rules define "close" words +;;; which are possible corrections: +;;; 1] two adjacent letters are transposed to form a correct spelling; +;;; 2] one letter is changed to form a correct spelling; +;;; 3] one letter is added to form a correct spelling; and/or +;;; 4] one letter is removed to form a correct spelling. +;;; There are two restrictions on the length of a word in regards to its +;;; worthiness of recognition: it must be at least more than two letters +;;; long, and if it has a suffix, then it must be at least four letters +;;; long. More will be said about this when the flags are discussed. +;;; This is implemented in as tense a fashion as possible, and it uses +;;; implementation dependent code from Spell-RT.Lisp to accomplish this. +;;; In general the file I/O and structure accesses encompass the system +;;; dependencies. + +;;; This next section will discuss the storage of the dictionary +;;; information. There are three data structures that "are" the +;;; dictionary: a hash table, descriptors table, and a string table. The +;;; hash table is a vector of type '(unsigned-byte 16), whose elements +;;; point into the descriptors table. This is a cyclic hash table to +;;; facilitate dumping it to a file. The descriptors table (also of type +;;; '(unsigned-byte 16)) dedicates three elements to each entry in the +;;; dictionary. Each group of three elements has the following organization +;;; imposed on them: +;;; ---------------------------------------------- +;;; | 15..5 hash code | 4..0 length | +;;; ---------------------------------------------- +;;; | 15..0 character index | +;;; ---------------------------------------------- +;;; | 15..14 character index | 13..0 flags | +;;; ---------------------------------------------- +;;; "Length" is the number of characters in the entry; "hash code" is some +;;; eleven bits from the hash code to allow for quicker lookup, "flags" +;;; indicate possible suffixes for the basic entry, and "character index" +;;; is the index of the start of the entry in the string table. +;;; This was originally adopted due to the Perq's word size (can you guess? +;;; 16 bits, that's right). Note the constraint that is placed on the number +;;; of the entries, 21845, because the hash table could not point to more +;;; descriptor units (16 bits of pointer divided by three). Since a value of +;;; zero as a hash table element indicates an empty location, the zeroth element +;;; of the descriptors table must be unused (it cannot be pointed to). + + +;;; The following is a short discussion with examples of the correct +;;; use of the suffix flags. Let # and @ be symbols that can stand for any +;;; single letter. Upper case letters are constants. "..." stands for any +;;; string of zero or more letters, but note that no word may exist in the +;;; dictionary which is not at least 2 letters long, so, for example, FLY +;;; may not be produced by placing the "Y" flag on "F". Also, no flag is +;;; effective unless the word that it creates is at least 4 letters long, +;;; so, for example, WED may not be produced by placing the "D" flag on +;;; "WE". These flags and examples are from the Ispell documentation with +;;; only slight modifications. Here are the correct uses of the flags: +;;; +;;; "V" flag: +;;; ...E => ...IVE as in create => creative +;;; if # .ne. E, then ...# => ...#IVE as in prevent => preventive +;;; +;;; "N" flag: +;;; ...E => ...ION as in create => creation +;;; ...Y => ...ICATION as in multiply => multiplication +;;; if # .ne. E or Y, then ...# => ...#EN as in fall => fallen +;;; +;;; "X" flag: +;;; ...E => ...IONS as in create => creations +;;; ...Y => ...ICATIONS as in multiply => multiplications +;;; if # .ne. E or Y, ...# => ...#ENS as in weak => weakens +;;; +;;; "H" flag: +;;; ...Y => ...IETH as in twenty => twentieth +;;; if # .ne. Y, then ...# => ...#TH as in hundred => hundredth +;;; +;;; "Y" FLAG: +;;; ... => ...LY as in quick => quickly +;;; +;;; "G" FLAG: +;;; ...E => ...ING as in file => filing +;;; if # .ne. E, then ...# => ...#ING as in cross => crossing +;;; +;;; "J" FLAG" +;;; ...E => ...INGS as in file => filings +;;; if # .ne. E, then ...# => ...#INGS as in cross => crossings +;;; +;;; "D" FLAG: +;;; ...E => ...ED as in create => created +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IED as in imply => implied +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ED as in convey => conveyed +;;; if # .ne. E or Y, then ...# => ...#ED as in cross => crossed +;;; +;;; "T" FLAG: +;;; ...E => ...EST as in late => latest +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IEST as in dirty => dirtiest +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#EST as in gray => grayest +;;; if # .ne. E or Y, then ...# => ...#EST as in small => smallest +;;; +;;; "R" FLAG: +;;; ...E => ...ER as in skate => skater +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IER as in multiply => multiplier +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ER as in convey => conveyer +;;; if # .ne. E or Y, then ...# => ...#ER as in build => builder +;;; + +;;; "Z FLAG: +;;; ...E => ...ERS as in skate => skaters +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IERS as in multiply => multipliers +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#ERS as in slay => slayers +;;; if # .ne. E or Y, then ...@# => ...@#ERS as in build => builders +;;; +;;; "S" FLAG: +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@IES as in imply => implies +;;; if # .eq. S, X, Z, or H, +;;; then ...# => ...#ES as in fix => fixes +;;; if # .ne. S, X, Z, H, or Y, +;;; then ...# => ...#S as in bat => bats +;;; if # = Y, and @ = A, E, I, O, or U, +;;; then ...@# => ...@#S as in convey => conveys +;;; +;;; "P" FLAG: +;;; if # .ne. Y, or @ = A, E, I, O, or U, +;;; then ...@# => ...@#NESS as in late => lateness and +;;; gray => grayness +;;; if @ .ne. A, E, I, O, or U, +;;; then ...@Y => ...@INESS as in cloudy => cloudiness +;;; +;;; "M" FLAG: +;;; ... => ...'S as in DOG => DOG'S + + + +(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM")) + +(export '(spell-try-word spell-root-word spell-collect-close-words + maybe-read-spell-dictionary correct-spelling max-entry-length)) + + + +;;;; Some Constants + +;;; The next number (using 6 bits) is 63, and that's pretty silly because +;;; "supercalafragalistic" is less than 31 characters long. +;;; +(defconstant max-entry-length 31 + "This the maximum number of characters an entry may have.") + +;;; These are the flags (described above), and an entry is allowed a +;;; certain suffix if the appropriate bit is on in the third element of +;;; its descriptor unit (described above). +;;; +(defconstant V-mask (ash 1 13)) +(defconstant N-mask (ash 1 12)) +(defconstant X-mask (ash 1 11)) +(defconstant H-mask (ash 1 10)) +(defconstant Y-mask (ash 1 9)) +(defconstant G-mask (ash 1 8)) +(defconstant J-mask (ash 1 7)) +(defconstant D-mask (ash 1 6)) +(defconstant T-mask (ash 1 5)) +(defconstant R-mask (ash 1 4)) +(defconstant Z-mask (ash 1 3)) +(defconstant S-mask (ash 1 2)) +(defconstant P-mask (ash 1 1)) +(defconstant M-mask 1) + + +;;; These are the eleven bits of a computed hash that are stored as part of +;;; an entries descriptor unit. The shifting constant is how much the +;;; eleven bits need to be shifted to the right, so they take up the upper +;;; eleven bits of one 16-bit element in a descriptor unit. +;;; +(defconstant new-hash-byte (byte 11 13)) +(defconstant stored-hash-byte (byte 11 5)) + + +;;; The next two constants are used to extract information from an entry's +;;; descriptor unit. The first is the two most significant bits of 18 +;;; bits that hold an index into the string table where the entry is +;;; located. If this is confusing, regard the diagram of the descriptor +;;; units above. +;;; +(defconstant whole-index-high-byte (byte 2 16)) +(defconstant stored-index-high-byte (byte 2 14)) +(defconstant stored-length-byte (byte 5 0)) + + + +;;;; Some Specials and Accesses + +;;; *spell-aeiou* will have bits on that represent the capital letters +;;; A, E, I, O, and U to be used to determine if some word roots are legal +;;; for looking up. +;;; +(defvar *aeiou* + (make-array 128 :element-type 'bit :initial-element 0)) + +(setf (aref *aeiou* (char-code #\A)) 1) +(setf (aref *aeiou* (char-code #\E)) 1) +(setf (aref *aeiou* (char-code #\I)) 1) +(setf (aref *aeiou* (char-code #\O)) 1) +(setf (aref *aeiou* (char-code #\U)) 1) + + +;;; *sxzh* will have bits on that represent the capital letters +;;; S, X, Z, and H to be used to determine if some word roots are legal for +;;; looking up. +;;; +(defvar *sxzh* + (make-array 128 :element-type 'bit :initial-element 0)) + +(setf (aref *sxzh* (char-code #\S)) 1) +(setf (aref *sxzh* (char-code #\X)) 1) +(setf (aref *sxzh* (char-code #\Z)) 1) +(setf (aref *sxzh* (char-code #\H)) 1) + + +;;; SET-MEMBER-P will be used with *aeiou* and *sxzh* to determine if a +;;; character is in the specified set. +;;; +(eval-when (compile eval) +(defmacro set-member-p (char set) + `(not (zerop (the fixnum (aref (the simple-bit-vector ,set) + (char-code ,char)))))) +) ;eval-when + + +(defvar *dictionary*) +(defvar *dictionary-size*) +(defvar *descriptors*) +(defvar *descriptors-size*) +(defvar *string-table*) +(defvar *string-table-size*) + + +(eval-when (compile eval) + +;;; DICTIONARY-REF and DESCRIPTOR-REF are references to implementation +;;; dependent structures. *dictionary* and *descriptors* are "system +;;; area pointers" as a result of the way the binary file is opened for +;;; fast access. +;;; +(defmacro dictionary-ref (idx) + `(sapref *dictionary* ,idx)) + +(defmacro descriptor-ref (idx) + `(sapref *descriptors* ,idx)) + + +;;; DESCRIPTOR-STRING-START access an entry's (indicated by idx) +;;; descriptor unit (described at the beginning of the file) and returns +;;; the start index of the entry in the string table. The second of three +;;; words in the descriptor holds the 16 least significant bits of 18, and +;;; the top two bits of the third word are the 2 most significant bits. +;;; These 18 bits are the index into the string table. +;;; +(defmacro descriptor-string-start (idx) + `(dpb (the fixnum (ldb stored-index-high-byte + (the fixnum (descriptor-ref (+ 2 ,idx))))) + whole-index-high-byte + (the fixnum (descriptor-ref (1+ ,idx))))) + +) ;eval-when + + + +;;;; Top level Checking/Correcting + +;;; CORRECT-SPELLING can be called from top level to check/correct a words +;;; spelling. It is not used for any other purpose. +;;; +(defun correct-spelling (word) + "Check/correct the spelling of word. Output is done to *standard-output*." + (setf word (coerce word 'simple-string)) + (let ((word (string-upcase (the simple-string word))) + (word-len (length (the simple-string word)))) + (declare (simple-string word) (fixnum word-len)) + (maybe-read-spell-dictionary) + (when (= word-len 1) + (error "Single character words are not in the dictionary.")) + (when (> word-len max-entry-length) + (error "~A is too long for the dictionary." word)) + (multiple-value-bind (idx used-flag-p) + (spell-try-word word word-len) + (if idx + (format t "Found it~:[~; because of ~A~]." used-flag-p + (spell-root-word idx)) + (let ((close-words (spell-collect-close-words word))) + (if close-words + (format *standard-output* + "The possible correct spelling~[~; is~:;s are~]:~ + ~:*~[~; ~{~A~}~;~{ ~A~^ and~}~:;~ + ~{~#[~; and~] ~A~^,~}~]." + (length close-words) + close-words) + (format *standard-output* "Word not found."))))))) + + +(defvar *dictionary-read-p* nil) + +;;; MAYBE-READ-SPELL-DICTIONARY -- Public +;;; +(defun maybe-read-spell-dictionary () + "Read the spelling dictionary if it has not be read already." + (unless *dictionary-read-p* (read-dictionary))) + + +(defun spell-root-word (index) + "Return the root word corresponding to a dictionary entry at index." + (let* ((start (descriptor-string-start index)) + (end (+ start (the fixnum (ldb stored-length-byte + (the fixnum (descriptor-ref index))))))) + (declare (fixnum start end)) + (subseq (the simple-string *string-table*) start end))) + + +(eval-when (compile eval) +(defmacro check-closeness (word word-len closeness-list) + `(if (spell-try-word ,word ,word-len) + (pushnew (subseq ,word 0 ,word-len) ,closeness-list :test #'string=))) +) ;eval-when + +(defconstant spell-alphabet + (list #\A #\B #\C #\D #\E #\F #\G #\H + #\I #\J #\K #\L #\M #\N #\O #\P + #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) + +;;; SPELL-COLLECT-CLOSE-WORDS Returns a list of all "close" correctly spelled +;;; words. The definition of "close" is at the beginning of the file, and +;;; there are four sections to this function which collect each of the four +;;; different kinds of close words. +;;; +(defun spell-collect-close-words (word) + "Returns a list of all \"close\" correctly spelled words. This has the + same contraints as SPELL-TRY-WORD, which you have probably already called + if you are calling this." + (declare (simple-string word)) + (let* ((word-len (length word)) + (word-len--1 (1- word-len)) + (word-len-+1 (1+ word-len)) + (result ()) + (correcting-buffer (make-string max-entry-length))) + (declare (simple-string correcting-buffer) + (fixnum word-len word-len--1 word-len-+1)) + (replace correcting-buffer word :end1 word-len :end2 word-len) + + ;; Misspelled because one letter is different. + (dotimes (i word-len) + (do ((save-char (schar correcting-buffer i)) + (alphabet spell-alphabet (cdr alphabet))) + ((null alphabet) + (setf (schar correcting-buffer i) save-char)) + (setf (schar correcting-buffer i) (car alphabet)) + (check-closeness correcting-buffer word-len result))) + + ;; Misspelled because two adjacent letters are transposed. + (dotimes (i word-len--1) + (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i))) + (check-closeness correcting-buffer word-len result) + (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i)))) + + ;; Misspelled because of extraneous letter. + (replace correcting-buffer word + :start2 1 :end1 word-len--1 :end2 word-len) + (check-closeness correcting-buffer word-len--1 result) + (dotimes (i word-len--1) + (setf (schar correcting-buffer i) (schar word i)) + (replace correcting-buffer word + :start1 (1+ i) :start2 (+ i 2) :end1 word-len--1 :end2 word-len) + (check-closeness correcting-buffer word-len--1 result)) + + ;; Misspelled because a letter is missing. + (replace correcting-buffer word + :start1 1 :end1 word-len-+1 :end2 word-len) + (dotimes (i word-len-+1) + (do ((alphabet spell-alphabet (cdr alphabet))) + ((null alphabet) + (rotatef (schar correcting-buffer i) + (schar correcting-buffer (1+ i)))) + (setf (schar correcting-buffer i) (car alphabet)) + (check-closeness correcting-buffer word-len-+1 result))) + result)) + +;;; SPELL-TRY-WORD The literal 4 is not a constant defined somewhere since it +;;; is part of the definition of the function of looking up words. +;;; TRY-WORD-ENDINGS relies on the guarantee that word-len is at least 4. +;;; +(defun spell-try-word (word word-len) + "See if the word or an appropriate root is in the spelling dicitionary. + Word-len must be inclusively in the range 2..max-entry-length." + (or (lookup-entry word word-len) + (if (>= (the fixnum word-len) 4) + (try-word-endings word word-len)))) + + + +;;;; Divining Correct Spelling + +(eval-when (compile eval) + +(defmacro setup-root-buffer (word buffer root-len) + `(replace ,buffer ,word :end1 ,root-len :end2 ,root-len)) + +(defmacro try-root (word root-len flag-mask) + (let ((result (gensym))) + `(let ((,result (lookup-entry ,word ,root-len))) + (if (and ,result (descriptor-flag ,result ,flag-mask)) + (return (values ,result ,flag-mask)))))) + +;;; TRY-MODIFIED-ROOT is used for root words that become truncated +;;; when suffixes are added (e.g., skate => skating). Char-idx is the last +;;; character in the root that has to typically be changed from a #\I to a +;;; #\Y or #\E. +;;; +(defmacro try-modified-root (word buffer root-len flag-mask char-idx new-char) + (let ((root-word (gensym))) + `(let ((,root-word (setup-root-buffer ,word ,buffer ,root-len))) + (setf (schar ,root-word ,char-idx) ,new-char) + (try-root ,root-word ,root-len ,flag-mask)))) + +) ;eval-when + + +(defvar *rooting-buffer* (make-string max-entry-length)) + +;;; TRY-WORD-ENDINGS takes a word that is at least of length 4 and +;;; returns multiple values on success (the index where the word's root's +;;; descriptor starts and :used-flag), otherwise nil. It looks at +;;; characters from the end to the beginning of the word to determine if it +;;; has any known suffixes. This is a VERY simple finite state machine +;;; where all of the suffixes are narrowed down to one possible one in at +;;; most two state changes. This is a PROG form for speed, and in some sense, +;;; readability. The states of the machine are the flag names that denote +;;; suffixes. The two points of branching to labels are the very beginning +;;; of the PROG and the S state. This is a fairly straight forward +;;; implementation of the flag rules presented at the beginning of this +;;; file, with char-idx checks, so we do not index the string below zero. + +(defun try-word-endings (word word-len) + (declare (simple-string word) + (fixnum word-len)) + (prog* ((char-idx (1- word-len)) + (char (schar word char-idx)) + (rooting-buffer *rooting-buffer*) + flag-mask) + (declare (simple-string rooting-buffer) + (fixnum char-idx)) + (case char + (#\S (go S)) ;This covers over half of the possible endings + ;by branching off the second to last character + ;to other flag states that have plural endings. + (#\R (setf flag-mask R-mask) ;"er" and "ier" + (go D-R-Z-FLAG)) + (#\T (go T-FLAG)) ;"est" and "iest" + (#\D (setf flag-mask D-mask) ;"ed" and "ied" + (go D-R-Z-FLAG)) + (#\H (go H-FLAG)) ;"th" and "ieth" + (#\N (setf flag-mask N-mask) ;"ion", "ication", and "en" + (go N-X-FLAG)) + (#\G (setf flag-mask G-mask) ;"ing" + (go G-J-FLAG)) + (#\Y (go Y-FLAG)) ;"ly" + (#\E (go V-FLAG))) ;"ive" + (return nil) + + S + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) S-mask) + (return nil)) + (if (not (set-member-p char *sxzh*)) + (try-root word (1+ char-idx) S-mask))) + (case char + (#\E (go S-FLAG)) ;"es" and "ies" + (#\R (setf flag-mask Z-mask) ;"ers" and "iers" + (go D-R-Z-FLAG)) + (#\G (setf flag-mask J-mask) ;"ings" + (go G-J-FLAG)) + (#\S (go P-FLAG)) ;"ness" and "iness" + (#\N (setf flag-mask X-mask) ;"ions", "ications", and "ens" + (go N-X-FLAG)) + (#\' (try-root word char-idx M-mask))) + (return nil) + + S-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (set-member-p char *sxzh*) + (try-root word (1+ char-idx) S-mask)) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + S-mask char-idx #\Y)) + (return nil) + + D-R-Z-FLAG + (if (char/= (schar word (1- char-idx)) #\E) (return nil)) + (try-root word char-idx flag-mask) + (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) flag-mask) + (return nil)) + (if (char/= (schar word char-idx) #\E) + (try-root word (1+ char-idx) flag-mask))) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + flag-mask char-idx #\Y)) + (return nil) + + P-FLAG + (if (or (char/= (schar word (1- char-idx)) #\E) + (char/= (schar word (- char-idx 2)) #\N)) + (return nil)) + (if (<= (setf char-idx (- char-idx 3)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) P-mask) + (return nil))) + (try-root word (1+ char-idx) P-mask) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + P-mask char-idx #\Y)) + (return nil) + + G-J-FLAG + (if (< char-idx 3) (return nil)) + (setf char-idx (- char-idx 2)) + (setf char (schar word char-idx)) + (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\N)) + (return nil)) + (if (char/= (schar word (1- char-idx)) #\E) + (try-root word char-idx flag-mask)) + (try-modified-root word rooting-buffer (1+ char-idx) + flag-mask char-idx #\E) + (return nil) + + N-X-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (cond ((char= char #\E) + (setf char (schar word (1- char-idx))) + (if (and (char/= char #\Y) (char/= char #\E)) + (try-root word char-idx flag-mask)) + (return nil)) + ((char= char #\O) + (if (char= (schar word (1- char-idx)) #\I) + (try-modified-root word rooting-buffer char-idx + flag-mask (1- char-idx) #\E) + (return nil)) + (if (< char-idx 5) (return nil)) + (if (or (char/= (schar word (- char-idx 2)) #\T) + (char/= (schar word (- char-idx 3)) #\A) + (char/= (schar word (- char-idx 4)) #\C) + (char/= (schar word (- char-idx 5)) #\I)) + (return nil) + (setf char-idx (- char-idx 4))) + (try-modified-root word rooting-buffer char-idx + flag-mask (1- char-idx) #\Y)) + (t (return nil))) + + T-FLAG + (if (or (char/= (schar word (1- char-idx)) #\S) + (char/= (schar word (- char-idx 2)) #\E)) + (return nil) + (setf char-idx (1- char-idx))) + (try-root word char-idx T-mask) + (if (<= (setf char-idx (- char-idx 2)) 0) (return nil)) + (setf char (schar word char-idx)) + (if (char= char #\Y) + (if (set-member-p (schar word (1- char-idx)) *aeiou*) + (try-root word (1+ char-idx) T-mask) + (return nil)) + (if (char/= (schar word char-idx) #\E) + (try-root word (1+ char-idx) T-mask))) + (if (and (char= char #\I) + (not (set-member-p (schar word (1- char-idx)) *aeiou*))) + (try-modified-root word rooting-buffer (1+ char-idx) + T-mask char-idx #\Y)) + (return nil) + + H-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char/= char #\T) (return nil)) + (if (char/= (schar word (1- char-idx)) #\Y) + (try-root word char-idx H-mask)) + (if (and (char= (schar word (1- char-idx)) #\E) + (char= (schar word (- char-idx 2)) #\I)) + (try-modified-root word rooting-buffer (1- char-idx) + H-mask (- char-idx 2) #\Y)) + (return nil) + + Y-FLAG + (setf char-idx (1- char-idx)) + (setf char (schar word char-idx)) + (if (char= char #\L) + (try-root word char-idx Y-mask)) + (return nil) + + V-FLAG + (setf char-idx (- char-idx 2)) + (setf char (schar word char-idx)) + (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\V)) + (return nil)) + (if (char/= (schar word (1- char-idx)) #\E) + (try-root word char-idx V-mask)) + (try-modified-root word rooting-buffer (1+ char-idx) + V-mask char-idx #\E) + (return nil))) + + + +;;; DESCRIPTOR-FLAG returns t or nil based on whether the flag is on. +;;; From the diagram at the beginning of the file, we see that the flags +;;; are stored two words off of the first word in the descriptor unit for +;;; an entry. +;;; +(defun descriptor-flag (descriptor-start flag-mask) + (not (zerop + (the fixnum + (logand + (the fixnum (descriptor-ref (+ 2 (the fixnum descriptor-start)))) + (the fixnum flag-mask)))))) + + +;;;; Looking up Trials + +(eval-when (compile eval) + +;;; SPELL-STRING= determines if string1 and string2 are the same. Before +;;; it is called it is known that they are both of (- end1 0) length, and +;;; string2 is in system space. This is used in FOUND-ENTRY-P. +;;; +(defmacro spell-string= (string1 string2 end1 start2) + (let ((idx1 (gensym)) + (idx2 (gensym))) + `(do ((,idx1 0 (1+ ,idx1)) + (,idx2 ,start2 (1+ ,idx2))) + ((= ,idx1 ,end1) t) + (declare (fixnum ,idx1 ,idx2)) + (unless (= (the fixnum (char-code (schar ,string1 ,idx1))) + (the fixnum (string-sapref ,string2 ,idx2))) + (return nil))))) + +;;; FOUND-ENTRY-P determines if entry is what is described at idx. +;;; Hash-and-length is 16 bits that look just like the first word of any +;;; entry's descriptor unit (see diagram at the beginning of the file). If +;;; the word stored at idx and entry have the same hash bits and length, +;;; then we compare characters to see if they are the same. +;;; +(defmacro found-entry-p (idx entry entry-len hash-and-length) + `(if (= (the fixnum (descriptor-ref ,idx)) + (the fixnum ,hash-and-length)) + (spell-string= ,entry *string-table* ,entry-len + (descriptor-string-start ,idx)))) + +(defmacro hash2-increment (hash) + `(- (the fixnum *dictionary-size*) + 2 + (the fixnum (rem ,hash (- (the fixnum *dictionary-size*) 2))))) + +(defmacro hash2-loop ((location-var contents-var) + loc hash zero-contents-form + &optional body-form (for-insertion-p nil)) + (let ((incr (gensym))) + `(let* ((,incr (hash2-increment ,hash)) + (,location-var ,loc) + ,contents-var) + (declare (fixnum ,location-var ,contents-var ,incr)) + (loop (setf ,location-var + (rem (+ ,location-var ,incr) (the fixnum *dictionary-size*))) + (setf ,contents-var (dictionary-ref ,location-var)) + (if (zerop ,contents-var) (return ,zero-contents-form)) + ,@(if for-insertion-p + `((if (= ,contents-var -1) (return ,zero-contents-form)))) + (if (= ,location-var ,loc) (return nil)) + ,@(if body-form `(,body-form)))))) + +) ;eval-when + + +;;; LOOKUP-ENTRY returns the index of the first element of entry's +;;; descriptor unit on success, otherwise nil. +;;; +(defun lookup-entry (entry &optional len) + (declare (simple-string entry)) + (let* ((entry-len (or len (length entry))) + (hash (string-hash entry entry-len)) + (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash)) + stored-hash-byte + (the fixnum entry-len))) + (loc (rem hash (the fixnum *dictionary-size*))) + (loc-contents (dictionary-ref loc))) + (declare (fixnum entry-len hash hash-and-len loc)) + (cond ((zerop loc-contents) nil) + ((found-entry-p loc-contents entry entry-len hash-and-len) + loc-contents) + (t + (hash2-loop (loop-loc loc-contents) loc hash + nil + (if (found-entry-p loc-contents entry entry-len hash-and-len) + (return loc-contents))))))) + +;;;; Binary File Reading + +(defparameter default-binary-dictionary + "/usr/misc/.lisp/lib/spell-dictionary.bin") + +;;; This is the first thing in a spell binary dictionary file to serve as a +;;; quick check of its proposed contents. This particular number is +;;; "BILLS" on a calculator held upside-down. +;;; +(defconstant magic-file-id 57718) + +;;; These constants are derived from the order things are written to the +;;; binary dictionary in Spell-Build.Lisp. +;;; +(defconstant magic-file-id-loc 0) +(defconstant dictionary-size-loc 1) +(defconstant descriptors-size-loc 2) +(defconstant string-table-size-low-byte-loc 3) +(defconstant string-table-size-high-byte-loc 4) +(defconstant file-header-bytes 10) + +;;; Initially, there are no free descriptor elements and string table bytes, +;;; but when these structures are grown, they are grown by more than that +;;; which is necessary. +;;; +(defvar *free-descriptor-elements* 0) +(defvar *free-string-table-bytes* 0) + +;;; READ-DICTIONARY opens the dictionary and sets up the global structures +;;; manifesting the spelling dictionary. When computing the start addresses +;;; of these structures, we multiply by two since their sizes are in 16bit +;;; lengths while the RT is 8bit-byte addressable. +;;; +(defun read-dictionary (&optional (f default-binary-dictionary)) + (when *dictionary-read-p* + (setf *dictionary-read-p* nil) + (deallocate-bytes (system-address *dictionary*) + (* 2 (the fixnum *dictionary-size*))) + (deallocate-bytes (system-address *descriptors*) + (* 2 (the fixnum + (+ (the fixnum *descriptors-size*) + (the fixnum *free-descriptor-elements*))))) + (deallocate-bytes (system-address *string-table*) + (+ (the fixnum *string-table-size*) + (the fixnum *free-string-table-bytes*)))) + (setf *free-descriptor-elements* 0) + (setf *free-string-table-bytes* 0) + (let* ((fd (open-dictionary f)) + (header-info (read-dictionary-structure fd file-header-bytes))) + (unless (= (sapref header-info magic-file-id-loc) magic-file-id) + (deallocate-bytes (system-address header-info) file-header-bytes) + (error "File is not a dictionary: ~S." f)) + (setf *dictionary-size* (sapref header-info dictionary-size-loc)) + (setf *descriptors-size* (sapref header-info descriptors-size-loc)) + (setf *string-table-size* (sapref header-info string-table-size-low-byte-loc)) + (setf (ldb (byte 12 16) (the fixnum *string-table-size*)) + (the fixnum (sapref header-info string-table-size-high-byte-loc))) + (deallocate-bytes (system-address header-info) file-header-bytes) + (setf *dictionary* + (read-dictionary-structure fd (* 2 (the fixnum *dictionary-size*)))) + (setf *descriptors* + (read-dictionary-structure fd (* 2 (the fixnum *descriptors-size*)))) + (setf *string-table* (read-dictionary-structure fd *string-table-size*)) + (setf *dictionary-read-p* t) + (close-dictionary fd))) diff --git a/hemlock/spell-rt.lisp b/hemlock/spell-rt.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6a066541bf1396c39e3d2990f1b34f698bfb23de --- /dev/null +++ b/hemlock/spell-rt.lisp @@ -0,0 +1,93 @@ +;;; -*- Log: hemlock.log; Package: Spell -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; +;;; This file contains system dependent primitives for the spelling checking/ +;;; correcting code in Spell-Correct.Lisp, Spell-Augment.Lisp, and +;;; Spell-Build.Lisp. + +(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM")) + + +;;;; System Area Referencing and Setting + +(eval-when (compile eval) + +;;; MAKE-SAP returns pointers that *dictionary*, *descriptors*, and +;;; *string-table* are bound to. Address is in the system area. +;;; +(defmacro make-sap (address) + `(lisp::fixnum-to-sap ,address)) + +(defmacro system-address (sap) + `(lisp::sap-to-fixnum ,sap)) + + +(defmacro allocate-bytes (count) + `(make-sap (lisp::do-validate 0 ,count -1))) + +(defmacro deallocate-bytes (address byte-count) + `(mach::vm_deallocate lisp::*task-self* ,address ,byte-count)) + + +(defmacro sapref (sap offset) + `(%primitive 16bit-system-ref ,sap ,offset)) + +(defsetf sapref (sap offset) (value) + `(%primitive 16bit-system-set ,sap ,offset ,value)) + + +(defmacro sap-replace (dst-string src-string src-start dst-start dst-end) + `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end)) + +(defmacro string-sapref (sap index) + `(%primitive 8bit-system-ref ,sap ,index)) + + + +;;;; Primitive String Hashing + +;;; STRING-HASH employs the instruction SXHASH-SIMPLE-SUBSTRING which takes +;;; an end argument, so we do not have to use SXHASH. SXHASH would mean +;;; doing a SUBSEQ of entry. +;;; +(defmacro string-hash (string length) + `(%primitive sxhash-simple-substring ,string ,length)) + +) ;eval-when + + + +;;;; Binary Dictionary File I/O + +(defun open-dictionary (f) + (multiple-value-bind (filename existsp) + (lisp::predict-name f :for-input) + (unless existsp (error "Cannot find dictionary -- ~S." filename)) + (multiple-value-bind (fd err) + (mach:unix-open filename mach:o_rdonly 0) + (unless fd + (error "Opening ~S failed: ~A." filename err)) + (multiple-value-bind (winp dev-or-err) (mach:unix-fstat fd) + (unless winp (error "Opening ~S failed: ~A." filename dev-or-err)) + fd)))) + +(defun close-dictionary (fd) + (mach:unix-close fd)) + +(defun read-dictionary-structure (fd bytes) + (let* ((structure (allocate-bytes bytes))) + (multiple-value-bind (read-bytes err) + (mach:unix-read fd structure bytes) + (when (or (null read-bytes) (not (= bytes read-bytes))) + (deallocate-bytes (system-address structure) bytes) + (error "Reading dictionary structure failed: ~A." err)) + structure))) diff --git a/hemlock/streams.lisp b/hemlock/streams.lisp new file mode 100644 index 0000000000000000000000000000000000000000..dfdae2b4fba3bdf85ac13ce853e651253bd0e812 --- /dev/null +++ b/hemlock/streams.lisp @@ -0,0 +1,316 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file contains definitions of various types of streams used +;;; in Hemlock. They are implementation dependant, but should be +;;; portable to all implementations based on Spice Lisp with little +;;; difficulty. +;;; +;;; Written by Skef Wholey and Rob MacLachlan. +;;; + +(in-package "HEMLOCK-INTERNALS") + +(export '(make-hemlock-output-stream + hemlock-region-stream hemlock-region-stream-p + hemlock-output-stream make-hemlock-region-stream + hemlock-output-stream-p make-kbdmac-stream + modify-kbdmac-stream)) + +(defstruct (hemlock-output-stream + (:include stream + (:misc #'hemlock-output-misc)) + (:print-function %print-hemlock-output-stream) + (:constructor internal-make-hemlock-output-stream ())) + ;; + ;; The mark we insert at. + mark) + +(defun %print-hemlock-output-stream (s stream d) + (declare (ignore d s)) + (write-string "#<Hemlock output stream>" stream)) + +(defun make-hemlock-output-stream (mark &optional (buffered :line)) + "Returns an output stream whose output will be inserted at the Mark. + Buffered, which indicates to what extent the stream may be buffered + is one of the following: + :None -- The screen is brought up to date after each stream operation. + :Line -- The screen is brought up to date when a newline is written. + :Full -- The screen is not updated except explicitly via Force-Output." + (modify-hemlock-output-stream (internal-make-hemlock-output-stream) mark + buffered)) + + +(defun modify-hemlock-output-stream (stream mark buffered) + (unless (and (markp mark) + (memq (mark-kind mark) '(:right-inserting :left-inserting))) + (error "~S is not a permanent mark." mark)) + (setf (hemlock-output-stream-mark stream) mark) + (case buffered + (:none + (setf (lisp::stream-out stream) #'hemlock-output-unbuffered-out + (lisp::stream-sout stream) #'hemlock-output-unbuffered-sout)) + (:line + (setf (lisp::stream-out stream) #'hemlock-output-line-buffered-out + (lisp::stream-sout stream) #'hemlock-output-line-buffered-sout)) + (:full + (setf (lisp::stream-out stream) #'hemlock-output-buffered-out + (lisp::stream-sout stream) #'hemlock-output-buffered-sout)) + (t + (error "~S is a losing value for Buffered." buffered))) + stream) + +(defmacro with-left-inserting-mark ((var form) &body forms) + (let ((change (gensym))) + `(let* ((,var ,form) + (,change (eq (mark-kind ,var) :right-inserting))) + (unwind-protect + (progn + (when ,change + (setf (mark-kind ,var) :left-inserting)) + ,@forms) + (when ,change + (setf (mark-kind ,var) :right-inserting)))))) + +(defun hemlock-output-unbuffered-out (stream character) + (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) + (insert-character mark character) + (redisplay-windows-from-mark mark))) + +(defun hemlock-output-unbuffered-sout (stream string start end) + (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) + (insert-string mark string start end) + (redisplay-windows-from-mark mark))) + +(defun hemlock-output-buffered-out (stream character) + (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) + (insert-character mark character))) + +(defun hemlock-output-buffered-sout (stream string start end) + (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) + (insert-string mark string start end))) + +(defun hemlock-output-line-buffered-out (stream character) + (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) + (insert-character mark character) + (when (char= character #\newline) + (redisplay-windows-from-mark mark)))) + +(defun hemlock-output-line-buffered-sout (stream string start end) + (declare (simple-string string)) + (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) + (insert-string mark string start end) + (when (find #\newline string :start start :end end) + (redisplay-windows-from-mark mark)))) + +(defun hemlock-output-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:charpos (mark-charpos (hemlock-output-stream-mark stream))) + (:line-length + (let* ((buffer (line-buffer (mark-line (hemlock-output-stream-mark stream))))) + (when buffer + (do ((w (buffer-windows buffer) (cdr w)) + (min most-positive-fixnum (min (window-width (car w)) min))) + ((null w) + (if (/= min most-positive-fixnum) min)))))) + ((:finish-output :force-output) + (redisplay-windows-from-mark (hemlock-output-stream-mark stream))) + (:close (setf (hemlock-output-stream-mark stream) nil)) + (:element-type 'string-char))) + +(defstruct (hemlock-region-stream + (:include stream + (:in #'region-in) + (:misc #'region-misc) + (:in-buffer (make-string lisp::in-buffer-length))) + (:print-function %print-region-stream) + (:constructor internal-make-hemlock-region-stream (region mark))) + ;; + ;; The region we read from. + region + ;; + ;; The mark pointing to the next character to read. + mark) + +(defun %print-region-stream (s stream d) + (declare (ignore s d)) + (write-string "#<Hemlock region stream>" stream)) + +(defun make-hemlock-region-stream (region) + "Returns an input stream that will return successive characters from the + given Region when asked for input." + (internal-make-hemlock-region-stream + region (copy-mark (region-start region) :right-inserting))) + +(defun modify-hemlock-region-stream (stream region) + (setf (hemlock-region-stream-region stream) region + (lisp::stream-in-index stream) lisp::in-buffer-length) + (let* ((mark (hemlock-region-stream-mark stream)) + (start (region-start region)) + (start-line (mark-line start))) + ;; Make sure it's dead. + (delete-mark mark) + (setf (mark-line mark) start-line (mark-charpos mark) (mark-charpos start)) + (push mark (line-marks start-line))) + stream) + +(defun region-readline (stream eof-errorp eof-value) + (close-line) + (let ((mark (hemlock-region-stream-mark stream)) + (end (region-end (hemlock-region-stream-region stream)))) + (cond ((mark>= mark end) + (if eof-errorp + (error "~A hit end of file." stream) + (values eof-value nil))) + ((eq (mark-line mark) (mark-line end)) + (let* ((limit (mark-charpos end)) + (charpos (mark-charpos mark)) + (dst-end (- limit charpos)) + (result (make-string dst-end))) + (declare (simple-string result)) + (%sp-byte-blt (line-chars (mark-line mark)) charpos + result 0 dst-end) + (setf (mark-charpos mark) limit) + (values result t))) + ((= (mark-charpos mark) 0) + (let* ((line (mark-line mark)) + (next (line-next line))) + (always-change-line mark next) + (values (line-chars line) nil))) + (t + (let* ((line (mark-line mark)) + (chars (line-chars line)) + (next (line-next line)) + (charpos (mark-charpos mark)) + (dst-end (- (length chars) charpos)) + (result (make-string dst-end))) + (declare (simple-string chars result)) + (%sp-byte-blt chars charpos result 0 dst-end) + (setf (mark-charpos mark) 0) + (always-change-line mark next) + (values result nil)))))) + +(defun region-in (stream eof-errorp eof-value) + (close-line) + (let* ((mark (hemlock-region-stream-mark stream)) + (charpos (mark-charpos mark)) + (line (mark-line mark)) + (chars (line-chars line)) + (length (length chars)) + (last (region-end (hemlock-region-stream-region stream))) + (last-line (mark-line last)) + (buffer (lisp::stream-in-buffer stream)) start len) + (declare (fixnum length charpos last-charpos start len) + (simple-string chars)) + (cond + ((eq line last-line) + (let ((last-charpos (mark-charpos last))) + (setq len (- last-charpos charpos)) + (cond + ((>= charpos last-charpos) + (if eof-errorp + (error "~A hit end of file." stream) + (return-from region-in eof-value))) + ((> len lisp::in-buffer-length) + (%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length) + (setq start 0 len lisp::in-buffer-length)) + (t + (setq start (- lisp::in-buffer-length len)) + (%sp-byte-blt chars charpos buffer start lisp::in-buffer-length))))) + ((line> line last-line) + (if eof-errorp + (error "~a hit end of file." stream) + (return-from region-in eof-value))) + (t + (setq len (- length charpos)) + (cond + ((< len lisp::in-buffer-length) + (let ((end (1- lisp::in-buffer-length))) + (setq start (- lisp::in-buffer-length len 1)) + (%sp-byte-blt chars charpos buffer start end) + (setf (schar buffer end) #\newline)) + (incf len)) + (t + (%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length) + (setq start 0 len lisp::in-buffer-length))))) + (setf (lisp::stream-in-index stream) (1+ start)) + (character-offset mark len) + (schar buffer start))) + +(defun region-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:listen (mark< (hemlock-region-stream-mark stream) + (region-end (hemlock-region-stream-region stream)))) + (:read-line (region-readline stream arg1 arg2)) + (:clear-input (move-mark + (hemlock-region-stream-mark stream) + (region-end (hemlock-region-stream-region stream)))) + (:close + (delete-mark (hemlock-region-stream-mark stream)) + (setf (hemlock-region-stream-region stream) nil)) + (:element-type 'string-char))) + +;;;; Stuff to support keyboard macros. + +;;; Note that the buffers in these streams must be general vectors, because +;;; the characters may have bits. + +(defstruct (kbdmac-stream + (:include stream + (:in #'kbdmac-in) + (:listen #'kbdmac-listen) + (:misc #'kbdmac-misc)) + (:constructor make-kbdmac-stream ())) + ;; + ;; The simple-vector that holds the characters. + buffer + ;; + ;; Index of the next character. + index) + +;;; Kbdmac-In -- Internal +;;; +;;; This is the input method for a kbdmac stream. It just grabs a character +;;; and returns it, bumping the index. +;;; +(defun kbdmac-in (stream eof-errorp eof-value) + (declare (ignore eof-errorp eof-value)) + (let ((index (kbdmac-stream-index stream))) + (prog1 (setq *last-character-typed* + (svref (kbdmac-stream-buffer stream) index)) + (setf (kbdmac-stream-index stream) (1+ index))))) + +;;; Kbdmac-Misc -- Internal +;;; +;;; This is the misc method for kbdmac streams. Since any character +;;; that might have been read is included in the simulated input, listen +;;; will always return T. +;;; +(defun kbdmac-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:unread + (if (plusp (kbdmac-stream-index stream)) + (decf (kbdmac-stream-index stream)) + (error "Nothing to unread."))) + (:listen t) + (:element-type 'string-char)) + t) + +;;; Modify-Kbdmac-Stream -- Internal +;;; +;;; Bash the kbdmac-stream Stream so that it will return the Input. +;;; +(defun modify-kbdmac-stream (stream input) + (setf (kbdmac-stream-index stream) 0) + (setf (kbdmac-stream-buffer stream) input) + stream) diff --git a/hemlock/struct.lisp b/hemlock/struct.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c9e51959f13a9cdbdef99b3a755b874bc920a65b --- /dev/null +++ b/hemlock/struct.lisp @@ -0,0 +1,611 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Structures and assorted macros for Hemlock. +;;; + +(in-package "HEMLOCK-INTERNALS") + +(export '(mark mark-line mark-charpos markp region region-start region-end + regionp buffer bufferp buffer-modes buffer-point buffer-writable + buffer-delete-hook buffer-windows buffer-variables buffer-write-date + region regionp region-start region-end window windowp window-height + window-width window-display-start window-display-end window-point + commandp command command-function command-documentation + modeline-field modeline-field-p)) + + +;;;; Marks. + +(defstruct (mark (:print-function %print-hmark) + (:predicate markp) + (:copier nil) + (:constructor internal-make-mark (line charpos %kind))) + "A Hemlock mark object. See Hemlock Command Implementor's Manual for details." + line ; pointer to line + charpos ; character position + %kind) ; type of mark + +(setf (documentation 'markp 'function) + "Returns true if its argument is a Hemlock mark object, false otherwise.") +(setf (documentation 'mark-line 'function) + "Returns line that a Hemlock mark points to.") +(setf (documentation 'mark-charpos 'function) + "Returns the character position of a Hemlock mark. + A mark's character position is the index within the line of the character + following the mark.") + +(defstruct (font-mark (:print-function + (lambda (s stream d) + (declare (ignore d)) + (write-string "#<Hemlock Font-Mark \"" stream) + (%print-before-mark s stream) + (write-string "/\\" stream) + (%print-after-mark s stream) + (write-string "\">" stream))) + (:include mark) + (:copier nil) + (:constructor internal-make-font-mark + (line charpos %kind font))) + font) + +(defmacro fast-font-mark-p (s) + `(eq (svref ,s 0) 'font-mark)) + + + +;;;; Regions, buffers, modeline fields. + +;;; The region object: +;;; +(defstruct (region (:print-function %print-hregion) + (:predicate regionp) + (:copier nil) + (:constructor internal-make-region (start end))) + "A Hemlock region object. See Hemlock Command Implementor's Manual for details." + start ; starting mark + end) ; ending mark + +(setf (documentation 'regionp 'function) + "Returns true if its argument is a Hemlock region object, Nil otherwise.") +(setf (documentation 'region-end 'function) + "Returns the mark that is the end of a Hemlock region.") +(setf (documentation 'region-start 'function) + "Returns the mark that is the start of a Hemlock region.") + + +;;; The buffer object: +;;; +(defstruct (buffer (:constructor internal-make-buffer) + (:print-function %print-hbuffer) + (:copier nil) + (:predicate bufferp)) + "A Hemlock buffer object. See Hemlock Command Implementor's Manual for details." + %name ; name of the buffer (a string) + %region ; the buffer's region + %pathname ; associated pathname + modes ; list of buffer's mode names + mode-objects ; list of buffer's mode objects + bindings ; buffer's command table + point ; current position in buffer + (%writable t) ; t => can alter buffer's region + (modified-tick -2) ; The last time the buffer was modified. + (unmodified-tick -1) ; The last time the buffer was unmodified + windows ; List of all windows into this buffer. + var-values ; the buffer's local variables + variables ; string-table of local variables + write-date ; File-Write-Date for pathname. + display-start ; Window display start when switching to buf. + %modeline-fields ; List of modeline-field-info's. + (delete-hook nil)) ; List of functions to call upon deletion. + +(setf (documentation 'buffer-modes 'function) + "Return the list of the names of the modes active in a given buffer.") +(setf (documentation 'buffer-point 'function) + "Return the mark that is the current focus of attention in a buffer.") +(setf (documentation 'buffer-windows 'function) + "Return the list of windows that are displaying a given buffer.") +(setf (documentation 'buffer-variables 'function) + "Return the string-table of the variables local to the specifed buffer.") +(setf (documentation 'buffer-write-date 'function) + "Return in universal time format the write date for the file associated + with the buffer. If the pathname is set, then this should probably + be as well. Should be NIL if the date is unknown or there is no file.") +(setf (documentation 'buffer-delete-hook 'function) + "This is the list of buffer specific functions that Hemlock invokes when + deleting this buffer.") + + +;;; Modeline fields. +;;; +(defstruct (modeline-field (:print-function print-modeline-field) + (:constructor %make-modeline-field + (%name %function %width))) + "This is one item displayed in a Hemlock window's modeline." + %name ; EQL name of this field. + %function ; Function that returns a string for this field. + %width) ; Width to display this field in. + +(setf (documentation 'modeline-field-p 'function) + "Returns true if its argument is a modeline field object, nil otherwise.") + +(defstruct (modeline-field-info (:print-function print-modeline-field-info) + (:conc-name ml-field-info-) + (:constructor make-ml-field-info (field))) + field + (start nil) + (end nil)) + + + +;;;; The mode object. + +(defstruct (mode-object (:predicate modep) + (:copier nil) + (:print-function %print-hemlock-mode)) + name ; name of this mode + setup-function ; setup function for this mode + cleanup-function ; Cleanup function for this mode + bindings ; The mode's command table. + transparent-p ; Are key-bindings transparent? + hook-name ; The name of the mode hook. + major-p ; Is this a major mode? + precedence ; The precedence for a minor mode. + character-attributes ; Mode local character attributes + variables ; String-table of mode variables + var-values ; Alist for saving mode variables + documentation) ; Introductory comments for mode describing commands. + +(defun %print-hemlock-mode (object stream depth) + (declare (ignore depth)) + (write-string "#<Hemlock Mode \"" stream) + (write-string (mode-object-name object) stream) + (write-string "\">" stream)) + + + +;;;; Variables. + +;;; This holds information about Hemlock variables, and the system stores +;;; these structures on the property list of the variable's symbolic +;;; representation under the 'hemlock-variable-value property. +;;; +(defstruct (variable-object + (:print-function + (lambda (object stream depth) + (declare (ignore depth)) + (format stream "#<Hemlock Variable-Object ~S>" + (variable-object-name object)))) + (:copier nil) + (:constructor make-variable-object (documentation name))) + value ; The value of this variable. + hooks ; The hook list for this variable. + down ; The variable-object for the previous value. + documentation ; The documentation. + name) ; The string name. + + + +;;;; Windows, dis-lines, and font-changes. + +;;; The window object: +;;; +(defstruct (window (:constructor internal-make-window) + (:predicate windowp) + (:copier nil) + (:print-function %print-hwindow)) + "This structure implements a Hemlock window." + tick ; The last time this window was updated. + %buffer ; buffer displayed in this window. + height ; Height of window in lines. + width ; Width of the window in characters. + old-start ; The charpos of the first char displayed. + first-line ; The head of the list of dis-lines. + last-line ; The last dis-line displayed. + first-changed ; The first changed dis-line on last update. + last-changed ; The last changed dis-line. + spare-lines ; The head of the list of unused dis-lines + (old-lines 0) ; Slot used by display to keep state info + hunk ; The device hunk that displays this window. + display-start ; first character position displayed + display-end ; last character displayed + point ; Where the cursor is in this window. + modeline-dis-line ; Dis-line for modeline display. + modeline-buffer ; Complete string of all modeline data. + modeline-buffer-len) ; Valid chars in modeline-buffer. + +(setf (documentation 'windowp 'function) + "Returns true if its argument is a Hemlock window object, Nil otherwise.") +(setf (documentation 'window-height 'function) + "Return the height of a Hemlock window in character positions.") +(setf (documentation 'window-width 'function) + "Return the width of a Hemlock window in character positions.") +(setf (documentation 'window-display-start 'function) + "Return the mark which points before the first character displayed in + the supplied window.") +(setf (documentation 'window-display-end 'function) + "Return the mark which points after the last character displayed in + the supplied window.") +(setf (documentation 'window-point 'function) + "Return the mark that points to where the cursor is displayed in this + window. When the window is made current, the Buffer-Point of this + window's buffer is moved to this position. While the window is + current, redisplay makes this mark point to the same position as the + Buffer-Point of its buffer.") + +(defstruct (dis-line (:copier nil) + (:constructor nil)) + chars ; The line-image to be displayed. + (length 0 :type fixnum) ; Length of line-image. + font-changes) ; Font-Change structures for changes in this line. + +(defstruct (window-dis-line (:copier nil) + (:include dis-line) + (:constructor make-window-dis-line (chars)) + (:conc-name dis-line-)) + old-chars ; Line-Chars of line displayed. + line ; Line displayed. + (flags 0 :type fixnum) ; Bit flags indicate line status. + (delta 0 :type fixnum) ; # lines moved from previous position. + (position 0 :type fixnum) ; Line # to be displayed on. + (end 0 :type fixnum)) ; Index after last logical character displayed. + +(defstruct (font-change (:copier nil) + (:constructor make-font-change (next))) + x ; X position that change takes effect. + font ; Index into font-map of font to use. + next ; The next Font-Change on this dis-line. + mark) ; Font-Mark responsible for this change. + + + +;;;; Font family. + +(defstruct font-family + map ; Font-map for hunk. + height ; Height of char box includung VSP. + width ; Width of font. + baseline ; Pixels from top of char box added to Y. + cursor-width ; Pixel width of cursor. + cursor-height ; Pixel height of cursor. + cursor-x-offset ; Added to pos of UL corner of char box to get + cursor-y-offset) ; UL corner of cursor blotch. + + + +;;;; Attribute descriptors. + +(defstruct (attribute-descriptor + (:copier nil) + (:print-function %print-attribute-descriptor)) + "This structure is used internally in Hemlock to describe a character + attribute." + name + keyword + documentation + vector + hooks + end-value) + + + +;;;; Commands. + +(defstruct (command (:constructor internal-make-command + (%name documentation function)) + (:copier nil) + (:predicate commandp) + (:print-function %print-hcommand)) + %name ;The name of the command + documentation ;Command documentation string or function + function ;The function which implements the command + %bindings) ;Places where command is bound + +(setf (documentation 'commandp 'function) + "Returns true if its argument is a Hemlock command object, Nil otherwise.") +(setf (documentation 'command-documentation 'function) + "Return the documentation for a Hemlock command, given the command-object. + Command documentation may be either a string or a function. This may + be set with Setf.") + + + +;;;; Random typeout streams. + +;;; These streams write to random typeout buffers for WITH-POP-UP-DISPLAY. +;;; +(defstruct (random-typeout-stream (:include stream) + (:print-function print-random-typeout-stream) + (:constructor + make-random-typeout-stream (mark))) + mark ; The buffer point of the associated buffer. + window ; The hemlock window all this shit is in. + more-mark ; The mark that is not displayed when we need to more. + no-prompt ; T when we want to exit, still collecting output. + (first-more-p t)) ; T until the first time we more. Nil after. + +(defun print-random-typeout-stream (object stream ignore) + (declare (ignore ignore)) + (format stream "#<Hemlock Random-Typeout-Stream ~S>" + (buffer-name + (line-buffer (mark-line (random-typeout-stream-mark object)))))) + + + +;;;; Redisplay devices. + +;;; Devices contain monitor specific redisplay methods referenced by +;;; redisplay independent code. +;;; +(defstruct (device (:print-function print-device) + (:constructor %make-device)) + name ; simple-string such as "concept" or "lnz". + init ; fun to call whenever going into the editor. + ; args: device + exit ; fun to call whenever leaving the editor. + ; args: device + smart-redisplay ; fun to redisplay a window on this device. + ; args: window &optional recenterp + dumb-redisplay ; fun to redisplay a window on this device. + ; args: window &optional recenterp + after-redisplay ; args: device + ; fun to call at the end of redisplay entry points. + clear ; fun to clear the entire display. + ; args: device + note-read-wait ; fun to somehow note on display that input is expected. + ; args: on-or-off + put-cursor ; fun to put the cursor at (x,y) or (column,line). + ; args: hunk &optional x y + show-mark ; fun to display the screens cursor at a certain mark. + ; args: window x y time + next-window ; funs to return the next and previous window + previous-window ; of some window. + ; args: window + make-window ; fun to make a window on the screen. + ; args: device start-mark + ; &optional modeline-string modeline-function + delete-window ; fun to remove a window from the screen. + ; args: window + random-typeout-setup ; fun to prepare for random typeout. + ; args: device n + random-typeout-cleanup; fun to clean up after random typeout. + ; args: device degree + random-typeout-line-more ; fun to keep line-buffered streams up to date. + random-typeout-full-more ; fun to do full-buffered more-prompting. + ; args: # of newlines in the object just inserted + ; in the buffer. + force-output ; if non-nil, fun to force any output possibly buffered. + finish-output ; if non-nil, fun to force output and hand until done. + ; args: device window + beep ; fun to beep or flash the screen. + bottom-window-base ; bottom text line of bottom window. + hunks) ; list of hunks on the screen. + +(defun print-device (obj str n) + (declare (ignore n)) + (format str "#<Hemlock Device ~S>" (device-name obj))) + + +(defstruct (bitmap-device #|(:print-function print-device)|# + (:include device)) + display) ; CLX display object. + + +(defstruct (tty-device #|(:print-function print-device)|# + (:constructor %make-tty-device) + (:include device)) + dumbp ; t if it does not have line insertion and deletion. + lines ; number of lines on device. + columns ; number of columns per line. + display-string ; fun to display a string of characters at (x,y). + ; args: hunk x y string &optional start end + standout-init ; fun to put terminal in standout mode. + ; args: hunk + standout-end ; fun to take terminal out of standout mode. + ; args: hunk + clear-lines ; fun to clear n lines starting at (x,y). + ; args: hunk x y n + clear-to-eol ; fun to clear to the end of a line from (x,y). + ; args: hunk x y + clear-to-eow ; fun to clear to the end of a window from (x,y). + ; args: hunk x y + open-line ; fun to open a line moving lines below it down. + ; args: hunk x y &optional n + delete-line ; fun to delete a line moving lines below it up. + ; args: hunk x y &optional n + insert-string ; fun to insert a string in the middle of a line. + ; args: hunk x y string &optional start end + delete-char ; fun to delete a character from the middle of a line. + ; args: hunk x y &optional n + (cursor-x 0) ; column the cursor is in. + (cursor-y 0) ; line the cursor is on. + standout-init-string ; string to put terminal in standout mode. + standout-end-string ; string to take terminal out of standout mode. + clear-to-eol-string ; string to cause device to clear to eol at (x,y). + clear-string ; string to cause device to clear entire screen. + open-line-string ; string to cause device to open a blank line. + delete-line-string ; string to cause device to delete a line, moving + ; lines below it up. + insert-init-string ; string to put terminal in insert mode. + insert-char-init-string ; string to prepare terminal for insert-mode character. + insert-char-end-string ; string to affect terminal after insert-mode character. + insert-end-string ; string to take terminal out of insert mode. + delete-init-string ; string to put terminal in delete mode. + delete-char-string ; string to delete a character. + delete-end-string ; string to take terminal out of delete mode. + init-string ; device init string. + cm-end-string ; takes device out of cursor motion mode. + (cm-x-add-char nil) ; char-code to unconditionally add to x coordinate. + (cm-y-add-char nil) ; char-code to unconditionally add to y coordinate. + (cm-x-condx-char nil) ; char-code threshold for adding to x coordinate. + (cm-y-condx-char nil) ; char-code threshold for adding to y coordinate. + (cm-x-condx-add-char nil) ; char-code to conditionally add to x coordinate. + (cm-y-condx-add-char nil) ; char-code to conditionally add to y coordinate. + cm-string1 ; initial substring of cursor motion string. + cm-string2 ; substring of cursor motion string between coordinates. + cm-string3 ; substring of cursor motion string after coordinates. + cm-one-origin ; non-nil if need to add one to coordinates. + cm-reversep ; non-nil if need to reverse coordinates. + (cm-x-pad nil) ; nil, 0, 2, or 3 for places to pad. + ; 0 sends digit-chars. + (cm-y-pad nil) ; nil, 0, 2, or 3 for places to pad. + ; 0 sends digit-chars. + screen-image) ; vector device-lines long of strings + ; device-columns long. + + + +;;;; Device screen hunks. + +;;; Device-hunks are used to claim a piece of the screen and for ordering +;;; pieces of the screen. Window motion primitives and splitting/merging +;;; primitives use hunks. Hunks are somewhat of an interface between the +;;; portable and non-portable parts of screen management, between what the +;;; user sees on the screen and how Hemlock internals deal with window +;;; sequencing and creation. Note: the echo area hunk is not hooked into +;;; the ring of other hunks via the next and previous fields. +;;; +(defstruct (device-hunk (:print-function %print-device-hunk)) + "This structure is used internally by Hemlock's screen management system." + window ; Window displayed in this hunk. + position ; Bottom Y position of hunk. + height ; Height of hunk in pixels or lines. + next ; Next and previous hunks. + previous + device) ; Display device hunk is on. + +(defun %print-device-hunk (object stream depth) + (declare (ignore depth)) + (format stream "#<Hemlock Device-Hunk ~D+~D~@[, ~S~]>" + (device-hunk-position object) + (device-hunk-height object) + (let* ((window (device-hunk-window object)) + (buffer (if window (window-buffer window)))) + (if buffer (buffer-name buffer))))) + + +;;; Bitmap hunks. +;;; +;;; The lock field is no longer used. If events could be handled while we +;;; were in the middle of something with the hunk, then this could be set +;;; for exclusion purposes. +;;; +(defstruct (bitmap-hunk #|(:print-function %print-device-hunk)|# + (:include device-hunk)) + width ; Pixel width. + char-height ; Height of text body in characters. + char-width ; Width in characters. + xwindow ; X window for this hunk. + gcontext ; X gcontext for xwindow. + start ; Head of dis-line list (no dummy). + end ; Exclusive end, i.e. nil if nil-terminated. + modeline-dis-line ; Dis-line for modeline, or NIL if none. + modeline-pos ; Position of modeline in pixels. + (lock t) ; Something going on, set trashed if we're changed. + trashed ; Something bad happened, recompute image. + font-family ; Font-family used in this window. + input-handler ; Gets hunk, char, x, y when char read. + changed-handler ; Gets hunk when size changed. + (thumb-bar-p nil)) ; True if we draw a thumb bar in the top border. + + +;;; Terminal hunks. +;;; +(defstruct (tty-hunk #|(:print-function %print-device-hunk)|# + (:include device-hunk)) + text-position ; Bottom Y position of text in hunk. + text-height) ; Number of lines of text. + + + +;;;; Some defsetfs: + +(defsetf buffer-writable %set-buffer-writable + "Sets whether the buffer is writable and invokes the Buffer Writable Hook.") +(defsetf buffer-name %set-buffer-name + "Sets the name of a specified buffer, invoking the Buffer Name Hook.") +(defsetf buffer-modified %set-buffer-modified + "Make a buffer modified or unmodified.") +(defsetf buffer-pathname %set-buffer-pathname + "Sets the pathname of a buffer, invoking the Buffer Pathname Hook.") + +(defsetf getstring %set-string-table + "Sets the value for a string-table entry, making a new one if necessary.") + +(defsetf window-buffer %set-window-buffer + "Change the buffer a window is mapped to.") + +(lisp::define-setf-method value (var) + "Set the value of a Hemlock variable, calling any hooks." + (let ((svar (gensym))) + (values + () + () + (list svar) + `(%set-value ',var ,svar) + `(value ,var)))) + +(defsetf variable-value (name &optional (kind :current) where) (new-value) + "Set the value of a Hemlock variable, calling any hooks." + `(%set-variable-value ,name ,kind ,where ,new-value)) + +(defsetf variable-hooks (name &optional (kind :current) where) (new-value) + "Set the list of hook functions for a Hemlock variable." + `(%set-variable-hooks ,name ,kind ,where ,new-value)) + +(defsetf variable-documentation (name &optional (kind :current) where) (new-value) + "Set a Hemlock variable's documentation." + `(%set-variable-documentation ,name ,kind ,where ,new-value)) + +(defsetf buffer-minor-mode %set-buffer-minor-mode + "Turn a buffer minor mode on or off.") +(defsetf buffer-major-mode %set-buffer-major-mode + "Set a buffer's major mode.") +(defsetf previous-character %set-previous-character + "Sets the character to the left of the given Mark.") +(defsetf next-character %set-next-character + "Sets the characters to the right of the given Mark.") +(defsetf character-attribute %set-character-attribute + "Set the value for a character attribute.") +(defsetf character-attribute-hooks %set-character-attribute-hooks + "Set the hook list for a Hemlock character attribute.") +(defsetf ring-ref %set-ring-ref "Set an element in a ring.") +(defsetf current-window %set-current-window "Set the current window.") +(defsetf current-buffer %set-current-buffer + "Set the current buffer, doing necessary stuff.") +(defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.") +(defsetf buffer-region %set-buffer-region "Set a buffer's region.") +(defsetf command-name %set-command-name + "Change a Hemlock command's name.") +(defsetf line-string %set-line-string + "Replace the contents of a line.") +(defsetf last-command-type %set-last-command-type + "Set the Last-Command-Type for use by the next command.") +(defsetf prefix-argument %set-prefix-argument + "Set the prefix argument for the next command.") +(defsetf logical-char= %set-logical-char= + "Change what Logical-Char= returns for the specified arguments.") +(defsetf window-font %set-window-font + "Change the font-object associated with a font-number in a window.") +(defsetf default-font %set-default-font + "Change the font-object associated with a font-number in new windows.") + +(defsetf buffer-modeline-fields %set-buffer-modeline-fields + "Sets the buffer's list of modeline fields causing all windows into buffer + to be updated for the next redisplay.") +(defsetf modeline-field-name %set-modeline-field-name + "Sets a modeline-field's name. If one already exists with that name, an + error is signaled.") +(defsetf modeline-field-width %set-modeline-field-width + "Sets a modeline-field's width and updates all the fields for all windows + in any buffer whose fields list contains the field.") +(defsetf modeline-field-function %set-modeline-field-function + "Sets a modeline-field's function and updates this field for all windows in + any buffer whose fields list contains the field.") diff --git a/hemlock/syntax.lisp b/hemlock/syntax.lisp new file mode 100644 index 0000000000000000000000000000000000000000..08a6b1f122e81280ab4b48fc3d056f41f44d1a1b --- /dev/null +++ b/hemlock/syntax.lisp @@ -0,0 +1,565 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Hemlock syntax table routines. +;;; +;;; Written by Rob MacLachlan. +;;; + +(in-package "HEMLOCK-INTERNALS") + +(export '(character-attribute-name + defattribute character-attribute-documentation character-attribute + character-attribute-hooks character-attribute-p shadow-attribute + unshadow-attribute find-attribute reverse-find-attribute)) + +;;;; Character attribute caching. +;;; +;;; In order to permit the %SP-Find-Character-With-Attribute sub-primitive +;;; to be used for a fast implementation of find-attribute and +;;; reverse-find-attribute, there must be some way of translating +;;; attribute/test-function pairs into a attribute vector and a mask. +;;; What we do is maintain a eq-hash-cache of attribute/test-function +;;; pairs. If the desired pair is not in the cache then we reclaim an old +;;; attribute bit in the bucket we hashed to and stuff it by calling the +;;; test function on the value of the attribute for all characters. + +(defvar *character-attribute-cache* () + "This is the cache used to translate attribute/test-function pairs to + attribute-vector/mask pairs for find-attribute and reverse-find-attribute.") + +(eval-when (compile eval) +(defconstant character-attribute-cache-size 13 + "The number of buckets in the *character-attribute-cache*.") +(defconstant character-attribute-bucket-size 3 + "The number of bits to use in each bucket of the + *character-attribute-cache*.") +); eval-when (compile eval) + +;;; In addition, since a common pattern in code which uses find-attribute +;;; is to repeatedly call it with the same function and attribute, we +;;; remember the last attribute/test-function pair that was used, and check +;;; if it is the same pair beforehand, thus often avoiding the hastable lookup. +;;; +(defvar *last-find-attribute-attribute* () + "The attribute which we last did a find-attribute on.") +(defvar *last-find-attribute-function* () + "The last test-function used for find-attribute.") +(defvar *last-find-attribute-vector* () + "The %SP-Find-Character-With-Attribute vector corresponding to the last + attribute/function pair used for find-attribute.") +(defvar *last-find-attribute-mask* () + "The the mask to use with *last-find-attribute-vector* to do a search + for the last attribute/test-function pair.") +(defvar *last-find-attribute-end-wins* () + "The the value of End-Wins for the last attribute/test-function pair.") + + +(defvar *character-attributes* (make-hash-table :test #'eq) + "A hash table which translates character attributes to their values.") +(defvar *last-character-attribute-requested* nil + "The last character attribute which was asked for, Do Not Bind.") +(defvar *value-of-last-character-attribute-requested* nil + "The value of the most recent character attribute, Do Not Bind.") + +(proclaim '(special *character-attribute-names*)) + + +;;; Each bucket contains a list of character-attribute-bucket-size +;;; bit-descriptors. +;;; +(defstruct (bit-descriptor) + function ; The test on the attribute. + attribute ; The attribute this is a test of. + (mask 0 :type fixnum) ; The mask for the corresponding bit. + vector ; The vector the bit is in. + end-wins) ; Is this test true of buffer ends? + +;;; +;;; In a descriptor for an unused bit, the function is nil, preventing a +;;; hit. Whenever we change the value of an attribute for some character, +;;; we need to flush the cache of any entries for that attribute. Currently +;;; we do this by mapping down the list of all bit descriptors. Note that +;;; we don't have to worry about GC, since this is just a hint. +;;; +(defvar *all-bit-descriptors* () "The list of all the bit descriptors.") + +(eval-when (compile eval) +(defmacro allocate-bit (vec bit-num) + `(progn + (when (= ,bit-num 8) + (setq ,bit-num 0 ,vec (make-array 256 :element-type '(mod 256)))) + (car (push (make-bit-descriptor + :vector ,vec + :mask (ash 1 (prog1 ,bit-num (incf ,bit-num)))) + *all-bit-descriptors*))))) +;;; +(defun %init-syntax-table () + (let ((tab (make-array character-attribute-cache-size)) + (bit-num 8) vec) + (setq *character-attribute-cache* tab) + (dotimes (c character-attribute-cache-size) + (setf (svref tab c) + (do ((i 0 (1+ i)) + (res ())) + ((= i character-attribute-bucket-size) res) + (push (allocate-bit vec bit-num) res)))))) + +(eval-when (compile eval) +(defmacro hash-it (attribute function) + `(abs (rem (logxor (ash (lisp::%sp-make-fixnum ,attribute) -3) + (lisp::%sp-make-fixnum ,function)) + character-attribute-cache-size))) + +;;; CACHED-ATTRIBUTE-LOOKUP -- Internal +;;; +;;; Sets Vector and Mask such that they can be used as arguments +;;; to %sp-find-character-with-attribute to effect a search with attribute +;;; Attribute and test Function. If the function and attribute +;;; are the same as the last ones then we just set them to that, otherwise +;;; we do the hash-cache lookup and update the *last-find-attribute-<mumble>* +;;; +(defmacro cached-attribute-lookup (attribute function vector mask end-wins) + `(if (and (eq ,function *last-find-attribute-function*) + (eq ,attribute *last-find-attribute-attribute*)) + (setq ,vector *last-find-attribute-vector* + ,mask *last-find-attribute-mask* + ,end-wins *last-find-attribute-end-wins*) + (let ((bit (svref *character-attribute-cache* + (hash-it ,attribute ,function)))) + ,(do ((res `(multiple-value-setq (,vector ,mask ,end-wins) + (new-cache-attribute ,attribute ,function)) + `(let ((b (car bit))) + (cond + ((and (eq (bit-descriptor-function b) + ,function) + (eq (bit-descriptor-attribute b) + ,attribute)) + (setq ,vector (bit-descriptor-vector b) + ,mask (bit-descriptor-mask b) + ,end-wins (bit-descriptor-end-wins b))) + (t + (setq bit (cdr bit)) ,res)))) + (count 0 (1+ count))) + ((= count character-attribute-bucket-size) res)) + (setq *last-find-attribute-attribute* ,attribute + *last-find-attribute-function* ,function + *last-find-attribute-vector* ,vector + *last-find-attribute-mask* ,mask + *last-find-attribute-end-wins* ,end-wins)))) +); eval-when (compile eval) + +;;; NEW-CACHE-ATTRIBUTE -- Internal +;;; +;;; Pick out an old attribute to punt out of the cache and put in the +;;; new one. We pick a bit off of the end of the bucket and pull it around +;;; to the beginning to get a degree of LRU'ness. +;;; +(defun new-cache-attribute (attribute function) + (let* ((hash (hash-it attribute function)) + (values (gethash attribute *character-attributes*)) + (bucket (svref *character-attribute-cache* hash)) + (bit (nthcdr (- character-attribute-bucket-size 2) bucket)) + (end-wins (funcall function (attribute-descriptor-end-value values)))) + (unless values + (error "~S is not a defined character attribute." attribute)) + (shiftf bit (cdr bit) nil) + (setf (svref *character-attribute-cache* hash) bit + (cdr bit) bucket bit (car bit)) + (setf (bit-descriptor-attribute bit) attribute + (bit-descriptor-function bit) function + (bit-descriptor-end-wins bit) end-wins) + (setq values (attribute-descriptor-vector values)) + (do ((mask (bit-descriptor-mask bit)) + (fun (bit-descriptor-function bit)) + (vec (bit-descriptor-vector bit)) + (i 0 (1+ i))) + ((= i syntax-char-code-limit) (values vec mask end-wins)) + (declare (type (simple-array (mod 256)) vec)) + (if (funcall fun (aref (the simple-array values) i)) + (setf (aref vec i) (logior (aref vec i) mask)) + (setf (aref vec i) (logandc2 (aref vec i) mask)))))) + +(defun %print-attribute-descriptor (object stream depth) + (declare (ignore depth)) + (format stream "#<Hemlock Attribute-Descriptor ~S>" + (attribute-descriptor-name object))) + +;;; DEFATTRIBUTE -- Public +;;; +;;; Make a new vector of some type and enter it in the table. +;;; +(defun defattribute (name documentation &optional (type '(mod 2)) + (initial-value 0)) + "Define a new Hemlock character attribute with named Name with + the supplied Documentation, Type and Initial-Value. Type + defaults to (mod 2) and Initial-Value defaults to 0." + (setq name (coerce name 'simple-string)) + (let* ((attribute (string-to-keyword name)) + (new (make-attribute-descriptor + :vector (make-array syntax-char-code-limit + :element-type type + :initial-element initial-value) + :name name + :keyword attribute + :documentation documentation + :end-value initial-value))) + (when (gethash attribute *character-attributes*) + (warn "Character Attribute ~S is being redefined." name)) + (setf (getstring name *character-attribute-names*) attribute) + (setf (gethash attribute *character-attributes*) new)) + name) + +;;; WITH-ATTRIBUTE -- Internal +;;; +;;; Bind obj to the attribute descriptor corresponding to symbol, +;;; giving error if it is not a defined attribute. +;;; +(eval-when (compile eval) +(defmacro with-attribute (symbol &body forms) + `(let ((obj (gethash ,symbol *character-attributes*))) + (unless obj + (error "~S is not a defined character attribute." ,symbol)) + ,@forms)) +); eval-when (compile eval) + +(defun character-attribute-name (attribute) + "Return the string-name of the character-attribute Attribute." + (with-attribute attribute + (attribute-descriptor-name obj))) + +(defun character-attribute-documentation (attribute) + "Return the documentation for the character-attribute Attribute." + (with-attribute attribute + (attribute-descriptor-documentation obj))) + +(defun character-attribute-hooks (attribute) + "Return the hook-list for the character-attribute Attribute. This can + be set with Setf." + (with-attribute attribute + (attribute-descriptor-hooks obj))) + +(defun %set-character-attribute-hooks (attribute new-value) + (with-attribute attribute + (setf (attribute-descriptor-hooks obj) new-value))) + +(proclaim '(special *last-character-attribute-requested* + *value-of-last-character-attribute-requested*)) + +;;; CHARACTER-ATTRIBUTE -- Public +;;; +;;; Return the value of a character attribute for some character. +;;; +(proclaim '(inline character-attribute)) +(defun character-attribute (attribute character) + "Return the value of the the character-attribute Attribute for Character. + If Character is Nil then return the end-value." + (if (and (eq attribute *last-character-attribute-requested*) character) + (aref (the simple-array *value-of-last-character-attribute-requested*) + (syntax-char-code character)) + (sub-character-attribute attribute character))) +;;; +(defun sub-character-attribute (attribute character) + (with-attribute attribute + (setq *last-character-attribute-requested* attribute) + (setq *value-of-last-character-attribute-requested* + (attribute-descriptor-vector obj)) + (if character + (aref (the simple-array *value-of-last-character-attribute-requested*) + (syntax-char-code character)) + (attribute-descriptor-end-value obj)))) + +;;; CHARACTER-ATTRIBUTE-P +;;; +;;; Look up attribute in table. +;;; +(defun character-attribute-p (symbol) + "Return true if Symbol is the symbol-name of a character-attribute, Nil + otherwise." + (not (null (gethash symbol *character-attributes*)))) + + +;;; %SET-CHARACTER-ATTRIBUTE -- Internal +;;; +;;; Set the value of a character attribute. +;;; +(defun %set-character-attribute (attribute character new-value) + (with-attribute attribute + (invoke-hook ed::character-attribute-hook attribute character new-value) + (invoke-hook (attribute-descriptor-hooks obj) attribute character new-value) + (cond + ;; + ;; Setting the value for a real character. + (character + (let ((value (attribute-descriptor-vector obj)) + (code (syntax-char-code character))) + (declare (type (simple-array *) value)) + (dolist (bit *all-bit-descriptors*) + (when (eq (bit-descriptor-attribute bit) attribute) + (let ((vec (bit-descriptor-vector bit))) + (declare (type (simple-array (mod 256)) vec)) + (setf (aref vec code) + (if (funcall (bit-descriptor-function bit) new-value) + (logior (bit-descriptor-mask bit) (aref vec code)) + (logandc1 (bit-descriptor-mask bit) (aref vec code))))))) + (setf (aref value code) new-value))) + ;; + ;; Setting the magical end-value. + (t + (setf (attribute-descriptor-end-value obj) new-value) + (dolist (bit *all-bit-descriptors*) + (when (eq (bit-descriptor-attribute bit) attribute) + (setf (bit-descriptor-end-wins bit) + (funcall (bit-descriptor-function bit) new-value)))) + new-value)))) + +(eval-when (compile eval) +;;; swap-one-attribute -- Internal +;;; +;;; Install the mode-local values described by Vals for Attribute, whose +;;; representation vector is Value. +;;; + (defmacro swap-one-attribute (attribute value vals hooks) + `(progn + ;; Fix up any cached attribute vectors. + (dolist (bit *all-bit-descriptors*) + (when (eq ,attribute (bit-descriptor-attribute bit)) + (let ((fun (bit-descriptor-function bit)) + (vec (bit-descriptor-vector bit)) + (mask (bit-descriptor-mask bit))) + (declare (type (simple-array (mod 256)) vec) + (fixnum mask)) + (dolist (char ,vals) + (setf (aref vec (car char)) + (if (funcall fun (cdr char)) + (logior mask (aref vec (car char))) + (logandc1 mask (aref vec (car char))))))))) + ;; Invoke the attribute-hook. + (dolist (hook ,hooks) + (dolist (char ,vals) + (funcall hook ,attribute (code-char (car char)) (cdr char)))) + ;; Fix up the value vector. + (dolist (char ,vals) + (rotatef (aref ,value (car char)) (cdr char))))) +); eval-when (compile eval) + + +;;; SWAP-CHAR-ATTRIBUTES -- Internal +;;; +;;; Swap the current values of character attributes and the ones +;;;specified by "mode". This is used in Set-Major-Mode. +;;; +(defun swap-char-attributes (mode) + (dolist (attribute (mode-object-character-attributes mode)) + (let* ((obj (car attribute)) + (sym (attribute-descriptor-keyword obj)) + (value (attribute-descriptor-vector obj)) + (hooks (attribute-descriptor-hooks obj))) + (declare (simple-array value)) + (swap-one-attribute sym value (cdr attribute) hooks)))) + + + +(proclaim '(special *mode-names* *current-buffer*)) + +;;; SHADOW-ATTRIBUTE -- Public +;;; +;;; Stick mode character attribute information in the mode object. +;;; +(defun shadow-attribute (attribute character value mode) + "Make a mode specific character attribute value. The value of + Attribute for Character when we are in Mode will be Value." + (let ((desc (gethash attribute *character-attributes*)) + (obj (getstring mode *mode-names*))) + (unless desc + (error "~S is not a defined Character Attribute." attribute)) + (unless obj (error "~S is not a defined Mode." mode)) + (let* ((current (assq desc (mode-object-character-attributes obj))) + (code (syntax-char-code character)) + (hooks (attribute-descriptor-hooks desc)) + (vec (attribute-descriptor-vector desc)) + (cons (cons code value))) + (declare (simple-array vec)) + (if current + (let ((old (assq code (cdr current)))) + (if old + (setf (cdr old) value cons old) + (push cons (cdr current)))) + (push (list desc cons) + (mode-object-character-attributes obj))) + (when (memq obj (buffer-mode-objects *current-buffer*)) + (let ((vals (list cons))) + (swap-one-attribute attribute vec vals hooks))) + (invoke-hook ed::shadow-attribute-hook attribute character value mode))) + attribute) + +;;; UNSHADOW-ATTRIBUTE -- Public +;;; +;;; Nuke a mode character attribute. +;;; +(defun unshadow-attribute (attribute character mode) + "Make the value of Attribte for Character no longer shadowed in Mode." + (let ((desc (gethash attribute *character-attributes*)) + (obj (getstring mode *mode-names*))) + (unless desc + (error "~S is not a defined Character Attribute." attribute)) + (unless obj + (error "~S is not a defined Mode." mode)) + (invoke-hook ed::shadow-attribute-hook mode attribute character) + (let* ((value (attribute-descriptor-vector desc)) + (hooks (attribute-descriptor-hooks desc)) + (current (assq desc (mode-object-character-attributes obj))) + (char (assq (syntax-char-code character) (cdr current)))) + (declare (simple-array value)) + (unless char + (error "Character Attribute ~S is not defined for character ~S ~ + in Mode ~S." attribute character mode)) + (when (memq obj (buffer-mode-objects *current-buffer*)) + (let ((vals (list char))) + (swap-one-attribute attribute value vals hooks))) + (setf (cdr current) (delete char (the list (cdr current)))))) + attribute) + + +;;; NOT-ZEROP, the default test function for find-attribute etc. +;;; +(defun not-zerop (n) + (not (zerop n))) + +;;; find-attribute -- Public +;;; +;;; Do hairy cache lookup to find a find-character-with-attribute style +;;; vector that we can use to do the search. +;;; +(eval-when (compile eval) +(defmacro normal-find-attribute (line start result vector mask) + `(let ((chars (line-chars ,line))) + (setq ,result (%sp-find-character-with-attribute + chars ,start (strlen chars) ,vector ,mask)))) +;;; +(defmacro cache-find-attribute (start result vector mask) + `(let ((gap (- right-open-pos left-open-pos))) + (declare (fixnum gap)) + (cond + ((>= ,start left-open-pos) + (setq ,result + (%sp-find-character-with-attribute + open-chars (+ ,start gap) line-cache-length ,vector ,mask)) + (when ,result (decf ,result gap))) + ((setq ,result (%sp-find-character-with-attribute + open-chars ,start left-open-pos ,vector ,mask))) + (t + (setq ,result + (%sp-find-character-with-attribute + open-chars right-open-pos line-cache-length ,vector ,mask)) + (when ,result (decf ,result gap)))))) +); eval-when (compile eval) +;;; +(defun find-attribute (mark attribute &optional (test #'not-zerop)) + "Find the next character whose attribute value satisfies test." + (let ((charpos (mark-charpos mark)) + (line (mark-line mark)) vector mask end-wins) + (declare (type (simple-array (mod 256)) vector) (fixnum mask)) + (cached-attribute-lookup attribute test vector mask end-wins) + (cond + ((cond + ((eq line open-line) + (when (cache-find-attribute charpos charpos vector mask) + (setf (mark-charpos mark) charpos) mark)) + (t + (when (normal-find-attribute line charpos charpos vector mask) + (setf (mark-charpos mark) charpos) mark)))) + ;; Newlines win and there is one. + ((and (not (zerop (logand mask (aref vector (char-code #\newline))))) + (line-next line)) + (move-to-position mark (line-length line) line)) + ;; We can ignore newlines. + (t + (do (prev) + (()) + (setq prev line line (line-next line)) + (cond + ((null line) + (if end-wins + (return (line-end mark prev)) + (return nil))) + ((eq line open-line) + (when (cache-find-attribute 0 charpos vector mask) + (return (move-to-position mark charpos line)))) + (t + (when (normal-find-attribute line 0 charpos vector mask) + (return (move-to-position mark charpos line)))))))))) + + +;;; REVERSE-FIND-ATTRIBUTE -- Public +;;; +;;; Line find-attribute, only goes backwards. +;;; +(eval-when (compile eval) +(defmacro rev-normal-find-attribute (line start result vector mask) + `(let ((chars (line-chars ,line))) + (setq ,result (%sp-reverse-find-character-with-attribute + chars 0 ,(or start '(strlen chars)) ,vector ,mask)))) +;;; +(defmacro rev-cache-find-attribute (start result vector mask) + `(let ((gap (- right-open-pos left-open-pos))) + (declare (fixnum gap)) + (cond + ,@(when start + `(((<= ,start left-open-pos) + (setq ,result + (%sp-reverse-find-character-with-attribute + open-chars 0 ,start ,vector ,mask))))) + ((setq ,result (%sp-reverse-find-character-with-attribute + open-chars right-open-pos + ,(if start `(+ ,start gap) 'line-cache-length) + ,vector ,mask)) + (decf ,result gap)) + (t + (setq ,result + (%sp-reverse-find-character-with-attribute + open-chars 0 left-open-pos ,vector ,mask)))))) + +); eval-when (compile eval) +;;; +(defun reverse-find-attribute (mark attribute &optional (test #'not-zerop)) + "Find the previous character whose attribute value satisfies test." + (let* ((charpos (mark-charpos mark)) + (line (mark-line mark)) vector mask end-wins) + (declare (type (simple-array (mod 256)) vector) + (fixnum charpos)) + (cached-attribute-lookup attribute test vector mask end-wins) + (cond + ((cond + ((eq line open-line) + (when (rev-cache-find-attribute charpos charpos vector mask) + (setf (mark-charpos mark) (1+ charpos)) mark)) + (t + (when (rev-normal-find-attribute line charpos charpos vector mask) + (setf (mark-charpos mark) (1+ charpos)) mark)))) + ;; Newlines win and there is one. + ((and (line-previous line) + (not (zerop (logand mask (aref vector (char-code #\newline)))))) + (move-to-position mark 0 line)) + (t + (do (next) + (()) + (setq next line line (line-previous line)) + (cond + ((null line) + (if end-wins + (return (line-start mark next)) + (return nil))) + ((eq line open-line) + (when (rev-cache-find-attribute nil charpos vector mask) + (return (move-to-position mark (1+ charpos) line)))) + (t + (when (rev-normal-find-attribute line nil charpos vector mask) + (return (move-to-position mark (1+ charpos) line)))))))))) diff --git a/hemlock/table.lisp b/hemlock/table.lisp new file mode 100644 index 0000000000000000000000000000000000000000..f046f15abad5c30f4b142ceaeebb94fd2b6d64b8 --- /dev/null +++ b/hemlock/table.lisp @@ -0,0 +1,744 @@ +;;; -*- Log: hemlock.log; Package: HEMLOCK-INTERNALS -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (Scott.Fahlman@CS.CMU.EDU). +;;; ********************************************************************** +;;; +;;; Reluctantly written by Christopher Hoover +;;; Supporting cast includes Rob and Bill. +;;; +;;; This file defines a data structure, analogous to a Common Lisp +;;; hashtable, which translates strings to values and facilitates +;;; recognition and completion of these strings. +;;; + +(in-package "HEMLOCK-INTERNALS") + +(export '(string-table string-table-p make-string-table + string-table-separator getstring + find-ambiguous complete-string find-containing + delete-string clrstring do-strings)) + + +;;;; Implementation Details + +;;; String tables are a data structure somewhat analogous to Common Lisp +;;; hashtables. String tables are case-insensitive. Functions are +;;; provided to quickly look up strings, insert strings, disambiguate or +;;; complete strings, and to provide a variety of ``help'' when +;;; disambiguating or completing strings. +;;; +;;; String tables are represented as a series of word tables which form +;;; a tree. Four structures are used to implement this data structure. +;;; The first is a STRING-TABLE. This structure has severals slots one +;;; of which, FIRST-WORD-TABLE, points to the first word table. This +;;; first word table is also the root of tree. The STRING-TABLE +;;; structure also contains slots to keep track of the number of nodes, +;;; the string table separator (which is used to distinguish word or +;;; field boundaries), and a pointer to an array of VALUE-NODE's. +;;; +;;; A WORD-TABLE is simply an array of pointers to WORD-ENTRY's. This +;;; array is kept sorted by the FOLDED slot in each WORD-ENTRY so that a +;;; binary search can be used. Each WORD-ENTRY contains a case-folded +;;; string and a pointer to the next WORD-TABLE in the tree. By +;;; traversing the tree made up by these structures, searching and +;;; completion can easily be done. +;;; +;;; Another structure, a VALUE-NODE, is used to hold each entry in the +;;; string table and contains both a copy of the original string and a +;;; case-folded version of the original string along with the value. +;;; All of these value nodes are stored in a array (pointed at by the +;;; VALUE-NODES slot of the STRING-TABLE structure) and sorted by the +;;; FOLDED slot in the VALUE-NODE structure so that a binary search may +;;; be used to quickly find existing strings. +;;; + + +;;;; Structure Definitions + +(defparameter initial-string-table-size 20 + "Initial size of string table array for value nodes.") +(defparameter initial-word-table-size 10 + "Inital size of each word table array for each tree node.") + +(defstruct (string-table + (:constructor %make-string-table (separator)) + (:print-function print-string-table)) + "This structure is used to implement the Hemlock string-table type." + ;; Character used to + (separator #\Space :type string-char) ; character used for word separator + (num-nodes 0 :type fixnum) ; number of nodes in string table + (value-nodes (make-array initial-string-table-size)) ; value node array + (first-word-table (make-word-table))) ; pointer to first WORD-TABLE + +(defun print-string-table (table stream depth) + (declare (ignore table depth)) + (format stream "#<String Table>")) + +(defun make-string-table (&key (separator #\Space) initial-contents) + "Creates and returns a Hemlock string-table. If Intitial-Contents is + supplied in the form of an A-list of string-value pairs, these pairs + will be used to initialize the table. If Separator, which must be a + string-char, is specified then it will be used to distinguish word + boundaries." + (let ((table (%make-string-table separator))) + (dolist (x initial-contents) + (setf (getstring (car x) table) (cdr x))) + table)) + + +(defstruct (word-table + (:print-function print-word-table)) + "This structure is a word-table which is part of a Hemlock string-table." + (num-words 0 :type fixnum) ; Number of words + (words (make-array initial-word-table-size))) ; Array of WORD-ENTRY's + +(defun print-word-table (table stream depth) + (declare (ignore table depth)) + (format stream "#<Word Table>")) + + +(defstruct (word-entry + (:constructor make-word-entry (folded)) + (:print-function print-word-entry)) + "This structure is an entry in a word table which is part of a Hemlock + string-table." + next-table ; Pointer to next WORD-TABLE + folded ; Downcased word + value-node) ; Pointer to value node or NIL + +(defun print-word-entry (entry stream depth) + (declare (ignore depth)) + (format stream "#<Word Table Entry: \"~A\">" (word-entry-folded entry))) + + +(defstruct (value-node + (:constructor make-value-node (proper folded value)) + (:print-function print-value-node)) + "This structure is a node containing a value in a Hemlock string-table." + folded ; Downcased copy of string + proper ; Proper copy of string entry + value) ; Value of entry + +(defun print-value-node (node stream depth) + (declare (ignore depth)) + (format stream "<Value Node \"~A\">" (value-node-proper node))) + + +;;;; Bi-SvPosition, String-Compare, String-Compare* + +;;; Much like the CL function POSITION; however, this is a fast binary +;;; search for simple vectors. Vector must be a simple vector and Test +;;; must be a function which returns either :equal, :less, or :greater. +;;; (The vector must be sorted from lowest index to highest index by the +;;; Test function.) Two values are returned: the first is the position +;;; Item was found or if it was not found, where it should be inserted; +;;; the second is a boolean flag indicating whether or not Item was +;;; found. +;;; +(defun bi-svposition (item vector test &key (start 0) end key) + (declare (simple-vector vector) (fixnum start)) + (let ((low start) + (high (if end end (length vector))) + (mid 0)) + (declare (fixnum low high mid)) + (loop + (when (< high low) (return (values low nil))) + (setf mid (+ (the fixnum (ash (the fixnum (- high low)) -1)) low)) + (let* ((array-item (svref vector mid)) + (test-item (if key (funcall key array-item) array-item))) + (ecase (funcall test item test-item) + (:equal (return (values mid t))) + (:less (setf high (1- mid))) + (:greater (setf low (1+ mid)))))))) + +;;; A simple-string comparison appropriate for use with BI-SVPOSITION. +;;; +(defun string-compare (s1 s2 &key (start1 0) end1 (start2 0) end2) + (declare (simple-string s1 s2) (fixnum start1 start2)) + (let* ((end1 (or end1 (length s1))) + (end2 (or end2 (length s2))) + (pos1 (string/= s1 s2 + :start1 start1 :end1 end1 :start2 start2 :end2 end2))) + (if (null pos1) + :equal + (let ((pos2 (+ (the fixnum pos1) (- start2 start1)))) + (declare (fixnum pos2)) + (cond ((= pos1 (the fixnum end1)) :less) + ((= pos2 (the fixnum end2)) :greater) + ((char< (schar s1 (the fixnum pos1)) (schar s2 pos2)) :less) + (t :greater)))))) + +;;; Macro to return a closure to call STRING-COMPARE with the given +;;; keys. +;;; +(defmacro string-compare* (&rest keys) + `#'(lambda (x y) (string-compare x y ,@keys))) + + +;;;; Insert-Element, Nconcf + +(eval-when (compile eval) + +;;; Insert-Element is a macro which encapsulates the hairiness of +;;; inserting an element into a simple vector. Vector should be a +;;; simple vector with Num elements (which may be less than or equal to +;;; the length of the vector) and Element is the element to insert at +;;; Pos. The optional argument Grow-Factor may be specified to control +;;; the new size of the array if a new vector is necessary. The result +;;; of INSERT-ELEMENT must be used as a new vector may be created. +;;; (Note that the arguments should probably be lexicals since some of +;;; them are evaluated more than once.) +;;; +(defmacro insert-element (vector pos element num &optional (grow-factor 2)) + `(let ((new-num (1+ ,num)) + (max (length ,vector))) + (declare (fixnum new-num max)) + (cond ((= ,num max) + ;; grow the vector + (let ((new (make-array (truncate (* max ,grow-factor))))) + (declare (simple-vector new)) + ;; Blt the new buggers into place leaving a space for + ;; the new element + (replace new ,vector :end1 ,pos :end2 ,pos) + (replace new ,vector :start1 (1+ ,pos) :end1 new-num + :start2 ,pos :end2 ,num) + (setf (svref new ,pos) ,element) + new)) + (t + ;; move the buggers down a slot + (replace ,vector ,vector :start1 (1+ ,pos) :start2 ,pos) + (setf (svref ,vector ,pos) ,element) + ,vector))))) + +(define-modify-macro nconcf (&rest args) nconc) + +) ; eval-when + + +;;;; With-Folded-String, Do-Words + +;;; With-Folded-String is a macro which deals with strings from the +;;; user. First, if the original string is not a simple string then it +;;; is coerced to one. Next, the string is trimmed using the separator +;;; character and all separators between words are collapsed to a single +;;; separator. The word boundaries are pushed on to a list so that the +;;; Do-Words macro can be called anywhere within the dynamic extent of a +;;; With-Folded-String to ``do'' over the words. + +(defvar *string-buffer-size* 128) +(defvar *string-buffer* (make-string *string-buffer-size*)) +(proclaim '(simple-string *string-buffer*)) + +(defvar *separator-positions* nil) + +(eval-when (compile eval) + +(defmacro do-words ((start-var end-var) &body (body decls)) + (let ((sep-pos (gensym))) + `(dolist (,sep-pos *separator-positions*) + (let ((,start-var (car ,sep-pos)) + (,end-var (cdr ,sep-pos))) + ,@decls + ,@body)))) + +(defmacro with-folded-string ((str-var len-var orig-str separator) + &body (body decls)) + `(let ((,str-var *string-buffer*)) + (declare (simple-string ,str-var)) + ;; make the string simple if it isn't already + (unless (simple-string-p ,orig-str) + (setq ,orig-str (coerce ,orig-str 'simple-string))) + ;; munge it into *string-buffer* and do the body + (let ((,len-var (with-folded-munge-string ,orig-str ,separator))) + ,@decls + ,@body))) + +) ; eval-when + +(defun with-folded-munge-string (str separator) + (declare (simple-string str) (string-char separator)) + (let ((str-len (length str)) + (sep-pos nil) + (buf-pos 0)) + ;; Make sure we have enough room to blt the string into place. + (when (> str-len *string-buffer-size*) + (setq *string-buffer-size* (* str-len 2)) + (setq *string-buffer* (make-string *string-buffer-size*))) + ;; Bash the spaces out of the string remembering where the words are. + (let ((start-pos (position separator str :test-not #'char=))) + (when start-pos + (loop + (let* ((end-pos (position separator str + :start start-pos :test #'char=)) + (next-start-pos (and end-pos (position separator str + :start end-pos + :test-not #'char=))) + (word-len (- (or end-pos str-len) start-pos)) + (new-buf-pos (+ buf-pos word-len))) + (replace *string-buffer* str + :start1 buf-pos :start2 start-pos :end2 end-pos) + (push (cons buf-pos new-buf-pos) sep-pos) + (setf buf-pos new-buf-pos) + (when (or (null end-pos) (null next-start-pos)) + (return)) + (setf start-pos next-start-pos) + (setf (schar *string-buffer* buf-pos) separator) + (incf buf-pos))))) + (nstring-downcase *string-buffer* :end buf-pos) + (setf *separator-positions* (nreverse sep-pos)) + buf-pos)) + + +;;;; Getstring, Setf Method for Getstring + +(defun getstring (string string-table) + "Looks up String in String-Table. Returns two values: the first is + the value of String or NIL if it does not exist; the second is a + boolean flag indicating whether or not String was found in + String-Table." + (with-folded-string (folded len string (string-table-separator string-table)) + (let ((nodes (string-table-value-nodes string-table)) + (num-nodes (string-table-num-nodes string-table))) + (declare (simple-vector nodes) (fixnum num-nodes)) + (multiple-value-bind + (pos found-p) + (bi-svposition folded nodes (string-compare* :end1 len) + :end (1- num-nodes) :key #'value-node-folded) + (if found-p + (values (value-node-value (svref nodes pos)) t) + (values nil nil)))))) + +(defun %set-string-table (string table value) + "Sets the value of String in Table to Value. If necessary, creates + a new entry in the string table." + (with-folded-string (folded len string (string-table-separator table)) + (when (zerop len) + (error "An empty string cannot be inserted into a string-table.")) + (let ((nodes (string-table-value-nodes table)) + (num-nodes (string-table-num-nodes table))) + (declare (simple-string folded) (simple-vector nodes) (fixnum num-nodes)) + (multiple-value-bind + (pos found-p) + (bi-svposition folded nodes (string-compare* :end1 len) + :end (1- num-nodes) :key #'value-node-folded) + (cond (found-p + (setf (value-node-value (svref nodes pos)) value)) + (t + ;; Note that a separator collapsed copy of string is NOT + ;; used here ... + ;; + (let ((node (make-value-node string (subseq folded 0 len) value)) + (word-table (string-table-first-word-table table))) + ;; put in the value nodes array + (setf (string-table-value-nodes table) + (insert-element nodes pos node num-nodes)) + (incf (string-table-num-nodes table)) + ;; insert it into the word tree + (%set-insert-words folded word-table node)))))) + value)) + +(defun %set-insert-words (folded first-word-table value-node) + (declare (simple-string folded)) + (let ((word-table first-word-table) + (entry nil)) + (do-words (word-start word-end) + (let ((word-array (word-table-words word-table)) + (num-words (word-table-num-words word-table))) + (declare (simple-vector word-array) (fixnum num-words)) + ;; find the entry or create a new one and insert it + (multiple-value-bind + (pos found-p) + (bi-svposition folded word-array + (string-compare* :start1 word-start :end1 word-end) + :end (1- num-words) :key #'word-entry-folded) + (declare (fixnum pos)) + (cond (found-p + (setf entry (svref word-array pos))) + (t + (setf entry (make-word-entry + (subseq folded word-start word-end))) + (setf (word-table-words word-table) + (insert-element word-array pos entry num-words)) + (incf (word-table-num-words word-table))))) + (let ((next-table (word-entry-next-table entry))) + (unless next-table + (setf next-table (make-word-table)) + (setf (word-entry-next-table entry) next-table)) + (setf word-table next-table)))) + (setf (word-entry-value-node entry) value-node))) + + +;;;; Find-Bound-Entries + +(defun find-bound-entries (word-entries) + (let ((res nil)) + (dolist (entry word-entries) + (nconcf res (sub-find-bound-entries entry))) + res)) + +(defun sub-find-bound-entries (entry) + (let ((bound-entries nil)) + (when (word-entry-value-node entry) (push entry bound-entries)) + (let ((next-table (word-entry-next-table entry))) + (when next-table + (let ((word-array (word-table-words next-table)) + (num-words (word-table-num-words next-table))) + (declare (simple-vector word-array) (fixnum num-words)) + (dotimes (i num-words) + (declare (fixnum i)) + (nconcf bound-entries + (sub-find-bound-entries (svref word-array i))))))) + bound-entries)) + + +;;;; Find-Ambiguous + +(defun find-ambiguous (string string-table) + "Returns a list, in alphabetical order, of all the strings in String-Table + which String matches." + (with-folded-string (folded len string (string-table-separator string-table)) + (find-ambiguous* folded len string-table))) + +(defun find-ambiguous* (folded len table) + (let ((word-table (string-table-first-word-table table)) + (word-entries nil)) + (cond ((zerop len) + (setf word-entries (find-ambiguous-entries "" 0 0 word-table))) + (t + (let ((word-tables (list word-table))) + (do-words (start end) + (setf word-entries nil) + (dolist (wt word-tables) + (nconcf word-entries + (find-ambiguous-entries folded start end wt))) + (unless word-entries (return)) + (let ((next-word-tables nil)) + (dolist (entry word-entries) + (let ((next-word-table (word-entry-next-table entry))) + (when next-word-table + (push next-word-table next-word-tables)))) + (unless next-word-tables (return)) + (setf word-tables (nreverse next-word-tables))))))) + (let ((bound-entries (find-bound-entries word-entries)) + (res nil)) + (dolist (be bound-entries) + (push (value-node-proper (word-entry-value-node be)) res)) + (nreverse res)))) + +(defun find-ambiguous-entries (folded start end word-table) + (let ((word-array (word-table-words word-table)) + (num-words (word-table-num-words word-table)) + (res nil)) + (declare (simple-vector word-array) (fixnum num-words)) + (unless (zerop num-words) + (multiple-value-bind + (pos found-p) + (bi-svposition folded word-array + (string-compare* :start1 start :end1 end) + :end (1- num-words) :key #'word-entry-folded) + (declare (ignore found-p)) + ;; + ;; Find last ambiguous string, checking for the end of the table. + (do ((i pos (1+ i))) + ((= i num-words)) + (declare (fixnum i)) + (let* ((entry (svref word-array i)) + (str (word-entry-folded entry)) + (str-len (length str)) + (index (string/= folded str :start1 start :end1 end + :end2 str-len))) + (declare (simple-string str) (fixnum str-len)) + (when (and index (/= index end)) (return nil)) + (push entry res))) + (setf res (nreverse res)) + ;; + ;; Scan back to the first string, checking for the beginning. + (do ((i (1- pos) (1- i))) + ((minusp i)) + (declare (fixnum i)) + (let* ((entry (svref word-array i)) + (str (word-entry-folded entry)) + (str-len (length str)) + (index (string/= folded str :start1 start :end1 end + :end2 str-len))) + (declare (simple-string str) (fixnum str-len)) + (when (and index (/= index end)) (return nil)) + (push entry res))))) + res)) + + +;;;; Find-Containing + +(defun find-containing (string string-table) + "Return a list in alphabetical order of all the strings in Table which + contain String as a substring." + (with-folded-string (folded len string (string-table-separator string-table)) + (declare (ignore len)) + (let ((word-table (string-table-first-word-table string-table)) + (words nil)) + ;; cons up a list of the words + (do-words (start end) + (push (subseq folded start end) words)) + (setf words (nreverse words)) + (let ((entries (sub-find-containing words word-table)) + (res nil)) + (dolist (e entries) + (push (value-node-proper (word-entry-value-node e)) res)) + (nreverse res))))) + +(defun sub-find-containing (words word-table) + (let ((res nil) + (word-array (word-table-words word-table)) + (num-words (word-table-num-words word-table))) + (declare (simple-vector word-array) (fixnum num-words)) + (dotimes (i num-words) + (declare (fixnum i)) + (let* ((entry (svref word-array i)) + (word (word-entry-folded entry)) + (found (find word words + :test #'(lambda (y x) + (let ((lx (length x)) + (ly (length y))) + (and (<= lx ly) + (string= x y :end2 lx)))))) + (rest-words (if found + (remove found words :test #'eq :count 1) + words))) + (declare (simple-string word)) + (cond (rest-words + (let ((next-table (word-entry-next-table entry))) + (when next-table + (nconcf res (sub-find-containing rest-words next-table))))) + (t + (nconcf res (sub-find-bound-entries entry)))))) + res)) + + +;;;; Complete-String + +(defvar *complete-string-buffer-size* 128) +(defvar *complete-string-buffer* (make-string *complete-string-buffer-size*)) +(proclaim '(simple-string *complete-string-buffer*)) + +(defun complete-string (string tables) + "Attempts to complete the string String against the string tables in the + list Tables. Tables must all use the same separator character. See the + manual for details on return values." + (let ((separator (string-table-separator (car tables)))) + #|(when (member separator (cdr tables) + :key #'string-table-separator :test-not #'char=) + (error "All tables must have the same separator."))|# + (with-folded-string (folded len string separator) + (let ((strings nil)) + (dolist (table tables) + (nconcf strings (find-ambiguous* folded len table))) + ;; pick off easy case + (when (null strings) + (return-from complete-string (values nil :none nil nil nil))) + ;; grow complete-string buffer if necessary + (let ((size-needed (1+ len))) + (when (> size-needed *complete-string-buffer-size*) + (let* ((new-size (* size-needed 2)) + (new-buffer (make-string new-size))) + (setf *complete-string-buffer* new-buffer) + (setf *complete-string-buffer-size* new-size)))) + (multiple-value-bind + (str ambig-pos unique-p) + (find-longest-completion strings separator) + (multiple-value-bind (value found-p) (find-values str tables) + (let ((field-pos (compute-field-pos string str separator))) + (cond ((not found-p) + (values str :ambiguous nil field-pos ambig-pos)) + (unique-p + (values str :unique value field-pos nil)) + (t + (values str :complete value field-pos ambig-pos)))))))))) + +(defun find-values (string tables) + (dolist (table tables) + (multiple-value-bind (value found-p) (getstring string table) + (when found-p + (return-from find-values (values value t))))) + (values nil nil)) + +(defun compute-field-pos (given best separator) + (declare (simple-string given best) (string-char separator)) + (let ((give-pos 0) + (best-pos 0)) + (loop + (setf give-pos (position separator given :start give-pos :test #'char=)) + (setf best-pos (position separator best :start best-pos :test #'char=)) + (unless (and give-pos best-pos) (return best-pos)) + (incf (the fixnum give-pos)) + (incf (the fixnum best-pos))))) + + +;;;; Find-Longest-Completion + +(defun find-longest-completion (strings separator) + (declare (string-char separator)) + (let ((first (car strings)) + (rest-strings (cdr strings)) + (punt-p nil) + (buf-pos 0) + (first-start 0) + (first-end -1) + (ambig-pos nil) + (maybe-unique-p nil)) + (declare (simple-string first) (fixnum buf-pos first-start)) + ;; + ;; Make room to store each string's next separator index. + (do ((l rest-strings (cdr l))) + ((endp l)) + (setf (car l) (cons (car l) -1))) + ;; + ;; Compare the rest of the strings to the first one. + ;; It's our de facto standard for how far we can go. + (loop + (setf first-start (1+ first-end)) + (setf first-end + (position separator first :start first-start :test #'char=)) + (unless first-end + (setf first-end (length first)) + (setf punt-p t) + (setf maybe-unique-p t)) + (let ((first-max first-end) + (word-ambiguous-p nil)) + (declare (fixnum first-max)) + ;; + ;; For each string, store the separator's next index. + ;; If there's no separator, store nil and prepare to punt. + ;; If the string's field is not equal to the first's, shorten the max + ;; expectation for this field, and declare ambiguity. + (dolist (s rest-strings) + (let* ((str (car s)) + (str-last-pos (cdr s)) + (str-start (1+ str-last-pos)) + (str-end (position separator str + :start str-start :test #'char=)) + (index (string-not-equal first str + :start1 first-start :end1 first-max + :start2 str-start :end2 str-end))) + (declare (simple-string str) (fixnum str-last-pos str-start)) + (setf (cdr s) str-end) + (unless str-end + (setf punt-p t) + (setf str-end (length str))) + (when index + (setf word-ambiguous-p t) ; not equal for some reason + (when (< index first-max) + (setf first-max index))))) + ;; + ;; Store what we matched into the result buffer and save the + ;; ambiguous position if its the first ambiguous field. + (let ((length (- first-max first-start))) + (declare (fixnum length)) + (unless (zerop length) + (unless (zerop buf-pos) + (setf (schar *complete-string-buffer* buf-pos) separator) + (incf buf-pos)) + (replace *complete-string-buffer* first + :start1 buf-pos :start2 first-start :end2 first-max) + (incf buf-pos length)) + (when (and (null ambig-pos) word-ambiguous-p) + (setf ambig-pos buf-pos)) + (when (or punt-p (zerop length)) (return))))) + (values + (subseq *complete-string-buffer* 0 buf-pos) + ;; If every corresponding field in each possible completion was equal, + ;; our result string is an initial substring of some other completion, + ;; so we're ambiguous at the end. + (or ambig-pos buf-pos) + (and (null ambig-pos) + maybe-unique-p + (every #'(lambda (x) (null (cdr x))) rest-strings))))) + + +;;;; Clrstring + +(defun clrstring (string-table) + "Delete all the entries in String-Table." + (fill (the simple-vector (string-table-value-nodes string-table)) nil) + (setf (string-table-num-nodes string-table) 0) + (let ((word-table (string-table-first-word-table string-table))) + (fill (the simple-vector (word-table-words word-table)) nil) + (setf (word-table-num-words word-table) 0)) + t) + + +;;;; Delete-String + +(defun delete-string (string string-table) + (with-folded-string (folded len string (string-table-separator string-table)) + (when (plusp len) + (let* ((nodes (string-table-value-nodes string-table)) + (num-nodes (string-table-num-nodes string-table)) + (end (1- num-nodes))) + (declare (simple-string folded) (simple-vector nodes) + (fixnum num-nodes end)) + (multiple-value-bind + (pos found-p) + (bi-svposition folded nodes (string-compare* :end1 len) + :end end :key #'value-node-folded) + (cond (found-p + (replace nodes nodes + :start1 pos :end1 end :start2 (1+ pos) :end2 num-nodes) + (setf (svref nodes end) nil) + (setf (string-table-num-nodes string-table) end) + (sub-delete-string folded string-table) + t) + (t nil))))))) + +(defun sub-delete-string (folded string-table) + (let ((next-table (string-table-first-word-table string-table)) + (word-table nil) + (node nil) + (entry nil) + (level -1) + last-table last-table-level last-table-pos + last-entry last-entry-level) + (declare (fixnum level)) + (do-words (start end) + (when node + (setf last-entry entry) + (setf last-entry-level level)) + (setf word-table next-table) + (incf level) + (let ((word-array (word-table-words word-table)) + (num-words (word-table-num-words word-table))) + (declare (simple-vector word-array) (fixnum num-words)) + (multiple-value-bind + (pos found-p) + (bi-svposition folded word-array + (string-compare* :start1 start :end1 end) + :end (1- num-words) :key #'word-entry-folded) + (declare (fixnum pos) (ignore found-p)) + (setf entry (svref word-array pos)) + (setf next-table (word-entry-next-table entry)) + (setf node (word-entry-value-node entry)) + (when (or (null last-table) (> num-words 1)) + (setf last-table word-table) + (setf last-table-pos pos) + (setf last-table-level level))))) + (cond (next-table + (setf (word-entry-value-node entry) nil)) + ((and last-entry-level + (>= last-entry-level last-table-level)) + (setf (word-entry-next-table last-entry) nil)) + (t + (let* ((del-word-array (word-table-words last-table)) + (del-num-words (word-table-num-words last-table)) + (del-end (1- del-num-words))) + (declare (simple-vector del-word-array) + (fixnum del-num-words del-end)) + (replace del-word-array del-word-array + :start1 last-table-pos :end1 del-end + :start2 (1+ last-table-pos) + :end2 del-num-words) + (setf (svref del-word-array del-end) nil) + (setf (word-table-num-words last-table) del-end)))))) diff --git a/hemlock/text.lisp b/hemlock/text.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5614724172a44b30dbe15cc938b5ead616b6ff3b --- /dev/null +++ b/hemlock/text.lisp @@ -0,0 +1,569 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles +;;; +;;; This file contains stuff that operates on units of texts, such as +;;; paragraphs, sentences, lines, and words. +;;; + +(in-package "HEMLOCK") + +;;;; -- New Variables -- + +(defhvar "Paragraph Delimiter Function" + "The function that returns whether or not the current line should break the + paragraph." + :value 'default-para-delim-function) + +;;; The standard paragraph delimiting function is DEFAULT-PARA-DELIM-FUNCTION +(defun default-para-delim-function (mark) + "Return whether or not to break on this line." + (paragraph-delimiter-attribute-p (next-character mark))) + +;;;; -- Paragraph Commands -- + +(defcommand "Forward Paragraph" (p) + "moves point to the end of the current (next) paragraph." + "moves point to the end of the current (next) paragraph." + (let ((point (current-point))) + (unless (paragraph-offset point (or p 1)) + (buffer-end point) + (editor-error)))) + +(defcommand "Backward Paragraph" (p) + "moves point to the start of the current (previous) paragraph." + "moves point to the start of the current (previous) paragraph." + (let ((point (current-point))) + (unless (paragraph-offset point (- (or p 1))) + (buffer-start point) + (editor-error)))) + +(defcommand "Mark Paragraph" (p) + "Put mark and point around current or next paragraph. + A paragraph is delimited by a blank line, a line beginning with a + special character (@,\,-,',and .), or it is begun with a line with at + least one whitespace character starting it. Prefixes are ignored or + skipped over before determining if a line starts or delimits a + paragraph." + "Put mark and point around current or next paragraph." + (declare (ignore p)) + (let* ((point (current-point)) + (mark (copy-mark point :temporary))) + (if (mark-paragraph point mark) + (push-buffer-mark mark t) + (editor-error)))) + +(defun mark-paragraph (mark1 mark2) + "Mark the next or current paragraph, setting mark1 to the beginning and mark2 + to the end. This uses \"Fill Prefix\", and mark1 is always on the first + line of the paragraph. If no paragraph is found, then the marks are not + moved, and nil is returned." + (with-mark ((tmark1 mark1) + (tmark2 mark2)) + (let* ((prefix (value fill-prefix)) + (prefix-len (length prefix)) + (paragraphp (paragraph-offset tmark2 1))) + (when (or paragraphp + (and (last-line-p tmark2) + (end-line-p tmark2) + (not (blank-line-p (mark-line tmark2))))) + (mark-before (move-mark tmark1 tmark2)) + (%fill-paragraph-start tmark1 prefix prefix-len) + (move-mark mark1 tmark1) + (move-mark mark2 tmark2))))) + + + +(eval-when (compile eval) + +;;; %MARK-TO-PARAGRAPH moves mark to next immediate (current) +;;; paragraph in the specified direction. Nil is returned when no +;;; paragraph is found. NOTE: the order of the arguments to OR within the +;;; first branch of the COND must be as it is, and mark must be at the +;;; beginning of the line it is on. +(defmacro %mark-to-paragraph (mark prefix prefix-length + &optional (direction :forward)) + `(do ((skip-prefix-p) + (paragraph-delim-function (value paragraph-delimiter-function))) + (nil) + (setf skip-prefix-p + (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length))) + (if skip-prefix-p (character-offset ,mark ,prefix-length)) + (let ((next-char (next-character ,mark))) + (cond ((and (not (blank-after-p ,mark)) + (or (whitespace-attribute-p next-char) + (not (funcall paragraph-delim-function ,mark)))) + (return (if skip-prefix-p (line-start ,mark) ,mark))) + (,(if (eq direction :forward) + `(last-line-p ,mark) + `(first-line-p ,mark)) + (if skip-prefix-p (line-start ,mark)) + (return nil))) + (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0)))) + + +;;; %PARAGRAPH-OFFSET-AUX is the inner loop of PARAGRAPH-OFFSET. It +;;; moves over a paragraph to find the beginning or end depending on +;;; direction. Prefixes on a line are ignored or skipped over before it +;;; is determined if the line is a paragraph boundary. +(defmacro %paragraph-offset-aux (mark prefix prefix-length + &optional (direction :forward)) + `(do ((paragraph-delim-function (value paragraph-delimiter-function)) + (skip-prefix-p)) + (nil) + (setf skip-prefix-p + (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length))) + (if skip-prefix-p (character-offset ,mark ,prefix-length)) + (cond ((or (blank-after-p ,mark) + (funcall paragraph-delim-function ,mark)) + (return (line-start ,mark))) + (,(if (eq direction :forward) + `(last-line-p ,mark) + `(first-line-p ,mark)) + (return ,(if (eq direction :forward) + `(line-end ,mark) + `(line-start ,mark))))) + (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0))) + +); (eval-when (compile eval) + + + +;;; PARAGRAPH-OFFSET takes a mark and a number of paragraphs to +;;; move over. If the specified number of paragraphs does not exist in +;;; the direction indicated by the sign of number, then nil is +;;; returned, otherwise the mark is returned. + +(defun paragraph-offset (mark number &optional (prefix (value fill-prefix))) + "moves mark past the specified number of paragraph, forward if the number + is positive and vice versa. If the specified number of paragraphs do + not exist in the direction indicated by the sign of the number, then nil + is returned, otherwise the mark is returned." + (if (plusp number) + (%paragraph-offset-forward mark number prefix) + (%paragraph-offset-backward mark number prefix))) + + + +;;; %PARAGRAPH-OFFSET-FORWARD moves mark forward over number +;;; paragraphs. The first branch of the COND is necessary for the side +;;; effect provided by LINE-OFFSET. If %MARK-TO-PARAGRAPH left tmark at +;;; the beginning of some paragraph %PARAGRAPH-OFFSET-AUX will think it has +;;; moved mark past a paragraph, so we make sure tmark is inside the +;;; paragraph or after it. + +(defun %paragraph-offset-forward (mark number prefix) + (do* ((n number (1- n)) + (tmark (line-start (copy-mark mark :temporary))) + (prefix-length (length prefix)) + (paragraphp (%mark-to-paragraph tmark prefix prefix-length) + (if (plusp n) + (%mark-to-paragraph tmark prefix prefix-length)))) + ((zerop n) (move-mark mark tmark)) + (cond ((and paragraphp (not (line-offset tmark 1))) ; + (if (or (> n 1) (and (last-line-p mark) (end-line-p mark))) + (return nil)) + (return (line-end (move-mark mark tmark)))) + (paragraphp (%paragraph-offset-aux tmark prefix prefix-length)) + (t (return nil))))) + + + +(defun %paragraph-offset-backward (mark number prefix) + (with-mark ((tmark1 mark) + (tmark2 mark)) + (do* ((n (abs number) (1- n)) + (prefix-length (length prefix)) + (paragraphp (%para-offset-back-find-para tmark1 prefix + prefix-length mark) + (if (plusp n) + (%para-offset-back-find-para tmark1 prefix + prefix-length tmark2)))) + ((zerop n) (move-mark mark tmark1)) + (cond ((and paragraphp (first-line-p tmark1)) + (if (and (first-line-p mark) (start-line-p mark)) + (return nil) + (if (> n 1) (return nil)))) + (paragraphp + (%paragraph-offset-aux tmark1 prefix prefix-length :backward) + (%para-offset-back-place-mark tmark1 prefix prefix-length)) + (t (return nil)))))) + + + +;;; %PARA-OFFSET-BACK-PLACE-MARK makes sure that mark is in +;;; the right place when it has been moved backward over a paragraph. The +;;; "right place" is defined to be where EMACS leaves it for a given +;;; situation or where it is necessary to ensure the mark's skipping +;;; backward over another paragraph if PARAGRAPH-OFFSET was given an +;;; argument with a greater magnitude than one. I believe these two +;;; constraints are equivalent; that is, neither changes what the other +;;; would dictate. + +(defun %para-offset-back-place-mark (mark prefix prefix-length) + (skip-prefix-if-here mark prefix prefix-length) + (cond ((text-blank-line-p mark) (line-start mark)) + ((not (first-line-p mark)) + (line-offset mark -1 0) + (skip-prefix-if-here mark prefix prefix-length) + (if (text-blank-line-p mark) + (line-start mark) + (line-offset mark 1 0))))) + + + +(defun %para-offset-back-find-para (mark1 prefix prefix-length mark2) + (move-mark mark2 mark1) + (line-start mark1) + (let ((para-p (%mark-to-paragraph mark1 prefix prefix-length :backward))) + (cond ((and para-p (same-line-p mark1 mark2)) + (skip-prefix-if-here mark1 prefix prefix-length) + (find-attribute mark1 :whitespace #'zerop) + (cond ((mark<= mark2 mark1) + (line-offset mark1 -1 0) + (%mark-to-paragraph mark1 prefix prefix-length :backward)) + (t (line-start mark1)))) + (t para-p)))) + + + +;;;; -- Sentence Commands -- + +(defcommand "Forward Sentence" (p) + "Moves forward one sentence or the specified number. + A sentence terminates with a .,?, or ! followed by any number of closing + delimiters (such as \",',),],>,|) which are followed by either two + spaces or a newline." + "Moves forward one sentence or the specified number." + (declare (ignore p)) + (unless (sentence-offset (current-point) (or p 1)) + (editor-error))) + + + +(defcommand "Backward Sentence" (p) + "Moves backward one sentence or the specified number. + A sentence terminates with a .,?, or ! followed by any number of closing + delimiters (such as \",',),],>,|) which are followed by either two + spaces or a newline." + "Moves backward one sentence or the specified number." + (declare (ignore p)) + (unless (sentence-offset (current-point) (- (or p 1))) + (editor-error))) + + + +(defcommand "Mark Sentence" (p) + "Put mark and point around current or next sentence. + A sentence terminates with a .,?, or ! followed by any number of closing + delimiters (such as \",',),],>,|) which are followed by either two + spaces or a newline." + "Put mark and point around current or next sentence." + (declare (ignore p)) + (let* ((point (current-point)) + (end (copy-mark point :temporary))) + (unless (sentence-offset end 1) (editor-error)) + (move-mark point end) + (sentence-offset point -1) + (push-buffer-mark end t))) + + +(defcommand "Forward Kill Sentence" (p) + "Kill forward to end of sentence." + "Kill forward to end of sentence." + (let ((point (current-point)) + (offset (or p 1))) + (with-mark ((mark point)) + (if (sentence-offset mark offset) + (if (plusp offset) + (kill-region (region point mark) :kill-forward) + (kill-region (region mark point) :kill-backward)) + (editor-error))))) + +(defcommand "Backward Kill Sentence" (p) + "Kill backward to beginning of sentence." + "Kill backward to beginning of sentence." + (forward-kill-sentence-command (- (or p 1)))) + +;;; SENTENCE-OFFSET-END-P returns true if mark is at the end of a +;;; sentence. If that the end of a sentence, it leaves mark at an +;;; appropriate position with respect to the sentence-terminator character, +;;; the beginning of the next sentence, and direction. See the commands +;;; "Forward Sentence" and "Backward Sentence" for a definition of a sentence. + +(eval-when (compile eval) +(defmacro sentence-offset-end-p (mark &optional (direction :forward)) + `(let ((start (mark-charpos ,mark))) + (do () + ((not (sentence-closing-char-attribute-p (next-character ,mark)))) + (mark-after ,mark)) + (cond ((char= (next-character ,mark) #\newline) + ,(if (eq direction :forward) mark `(mark-after ,mark))) + ((and (char= (next-character ,mark) #\space) + (or (char= (next-character (mark-after ,mark)) #\space) + (char= (next-character ,mark) #\newline))) + ,(if (eq direction :forward) + `(mark-before ,mark) + `(mark-after ,mark))) + (t (move-to-position ,mark start) + nil)))) +); (eval-when (compile eval) + + + +;;; SENTENCE-OFFSET-FIND-END moves in the direction direction stopping +;;; at sentence terminating characters until either there are not any more +;;; such characters or one is found that defines the end of a sentence. +;;; When looking backwards, we may be at the beginning of some sentence, +;;; and if we are, then we must move mark before the sentence terminator; +;;; otherwise, we would find the immediately preceding sentence terminator +;;; and end up right where we started. + +(eval-when (compile eval) +(defmacro sentence-offset-find-end (mark &optional (direction :forward)) + `(progn + ,@(if (eq direction :backward) + `((reverse-find-attribute ,mark :whitespace #'zerop) + (when (fill-region-insert-two-spaces-p ,mark) + (reverse-find-attribute ,mark :sentence-terminator) + (mark-before ,mark)))) + (do ((foundp) (endp)) (nil) + (setf foundp ,(if (eq direction :forward) + `(find-attribute ,mark :sentence-terminator) + `(reverse-find-attribute ,mark :sentence-terminator))) + (setf endp ,(if (eq direction :forward) + `(if foundp (progn (mark-after ,mark) + (sentence-offset-end-p ,mark))) + `(if foundp (sentence-offset-end-p ,mark :backward)))) + (if endp (return ,mark)) + ,(if (eq direction :forward) + `(unless foundp (return nil)) + `(if foundp (mark-before ,mark) (return nil)))))) +); (eval-when (compile eval) + + + +;;; SENTENCE-OFFSET takes a mark and a number of paragraphs to move +;;; over. If the specified number of paragraphs does not exist in +;;; the direction indicated by the sign of the number, then nil is returned, +;;; otherwise the mark is returned. + +(defun sentence-offset (mark number) + (if (plusp number) + (sentence-offset-forward mark number) + (sentence-offset-backward mark (abs number)))) + + + +;;; SENTENCE-OFFSET-FORWARD tries to move mark forward over number +;;; sentences. If it can, then mark is moved and returned; otherwise, mark +;;; remains unmoved, and nil is returned. When tmark2 is moved to the end +;;; of a new paragraph, we reverse find for a non-whitespace character to +;;; bring tmark2 to the end of the previous line. This is necessary to +;;; detect if tmark1 is at the end of the paragraph, in which case tmark2 +;;; wants to be moved over another paragraph. + +(defun sentence-offset-forward (mark number) + (with-mark ((tmark1 mark) + (tmark2 mark)) + (do ((n number (1- n)) + (found-paragraph-p)) + ((zerop n) (move-mark mark tmark1)) + (when (and (mark<= tmark2 tmark1) + (setf found-paragraph-p (paragraph-offset tmark2 1))) + (reverse-find-attribute tmark2 :whitespace #'zerop) + (when (mark>= tmark1 tmark2) + (line-offset tmark2 1 0) + (setf found-paragraph-p (paragraph-offset tmark2 1)) + (reverse-find-attribute tmark2 :whitespace #'zerop))) + (cond ((sentence-offset-find-end tmark1) + (if (mark> tmark1 tmark2) (move-mark tmark1 tmark2))) + (found-paragraph-p (move-mark tmark1 tmark2)) + (t (return nil)))))) + + + +(defun sentence-offset-backward (mark number) + (with-mark ((tmark1 mark) + (tmark2 mark) + (tmark3 mark)) + (do* ((n number (1- n)) + (prefix (value fill-prefix)) + (prefix-length (length prefix)) + (found-paragraph-p + (cond ((paragraph-offset tmark2 -1) + (sent-back-place-para-start tmark2 prefix prefix-length) + t)))) + ((zerop n) (move-mark mark tmark1)) + (move-mark tmark3 tmark1) + (when (and (sent-back-para-start-p tmark1 tmark3 prefix prefix-length) + (setf found-paragraph-p + (paragraph-offset (move-mark tmark2 tmark3) -1))) + (paragraph-offset (move-mark tmark1 tmark2) 1) + (sent-back-place-para-start tmark2 prefix prefix-length)) + (cond ((sentence-offset-find-end tmark1 :backward) + (if (mark< tmark1 tmark2) (move-mark tmark1 tmark2))) + (found-paragraph-p (move-mark tmark1 tmark2)) + (t (return nil)))))) + + + +(defun sent-back-para-start-p (mark1 mark2 prefix prefix-length) + (skip-prefix-if-here (line-start mark2) prefix prefix-length) + (cond ((text-blank-line-p mark2) + (line-start mark2)) + ((whitespace-attribute-p (next-character mark2)) + (find-attribute mark2 :whitespace #'zerop) + (if (mark= mark1 mark2) (line-offset mark2 -1 0))) + ((and (mark= mark2 mark1) (line-offset mark2 -1 0)) + (skip-prefix-if-here mark2 prefix prefix-length) + (if (text-blank-line-p mark2) + (line-start mark2))))) + + + +(defun sent-back-place-para-start (mark2 prefix prefix-length) + (skip-prefix-if-here mark2 prefix prefix-length) + (when (text-blank-line-p mark2) + (line-offset mark2 1 0) + (skip-prefix-if-here mark2 prefix prefix-length)) + (find-attribute mark2 :whitespace #'zerop)) + + + +;;;; -- Transposing Stuff -- + +(defcommand "Transpose Words" (p) + "Transpose the words before and after the cursor. + With a positive argument it transposes the words before and after the + cursor, moves right, and repeats the specified number of times, + dragging the word to the left of the cursor right. With a negative + argument, it transposes the two words to the left of the cursor, moves + between them, and repeats the specified number of times, exactly undoing + the positive argument form." + "Transpose the words before and after the cursor." + (let ((num (or p 1)) + (point (current-point))) + (with-mark ((mark point :left-inserting) + (start point :left-inserting)) + (let ((mark-prev (previous-character mark)) + (mark-next (next-character mark))) + (cond ((plusp num) + (let ((forwardp (word-offset point num)) + (backwardp (if (or (word-delimiter-attribute-p mark-next) + (word-delimiter-attribute-p mark-prev)) + (word-offset mark -1) + (word-offset mark -2)))) + (if (and forwardp backwardp) + (transpose-words-forward mark point start) + (editor-error)))) + ((minusp num) + (let ((enoughp (word-offset point (1- num)))) + (if (word-delimiter-attribute-p mark-prev) + (reverse-find-attribute mark :word-delimiter #'zerop) + (find-attribute mark :word-delimiter)) + (if enoughp + (transpose-words-backward point mark start) + (editor-error)))) + (t (editor-error))))))) + + +(defun transpose-words-forward (mark1 end mark2) + (with-mark ((tmark1 mark1 :left-inserting) + (tmark2 mark2 :left-inserting)) + (find-attribute tmark1 :word-delimiter) + (do ((region1 (delete-and-save-region (region mark1 tmark1)))) + ((mark= tmark2 end) (ninsert-region end region1)) + (word-offset tmark2 1) + (reverse-find-attribute (move-mark tmark1 tmark2) :word-delimiter) + (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2))) + (move-mark mark1 tmark1)))) + + +(defun transpose-words-backward (start mark1 mark2) + (with-mark ((tmark1 mark1 :left-inserting) + (tmark2 mark2 :left-inserting)) + (reverse-find-attribute tmark1 :word-delimiter) + (move-mark mark2 mark1) + (do ((region1 (delete-and-save-region (region tmark1 mark1)))) + ((mark= tmark1 start) (ninsert-region start region1)) + (word-offset tmark1 -1) + (find-attribute (move-mark tmark2 tmark1) :word-delimiter) + (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2))) + (move-mark mark1 tmark1)))) + +(defcommand "Transpose Lines" (p) + "Transpose the current line with the line before the cursor. + With a positive argument it transposes the current line with the one + before, moves down a line, and repeats the specified number of times, + dragging the originally current line down. With a negative argument, it + transposes the two lines to the prior to the current, moves up a line, + and repeats the specified number of times, exactly undoing the positive + argument form. With a zero argument, it transposes the lines at point + and mark." + "Transpose the current line with the line before the cursor." + (let ((num (or p 1)) + (point (current-point))) + (with-mark ((mark point :left-inserting)) + (cond ((plusp num) + (if (and (line-offset mark -1 0) + (line-offset point num 0)) + (transpose-lines mark point) + (editor-error))) + ((minusp num) + (cond ((and (line-offset mark (1- num) 0) + (line-offset point -1 0)) + (transpose-lines point mark) + (move-mark point mark)) + (t (editor-error)))) + (t + (rotatef (line-string (mark-line point)) + (line-string (mark-line (current-mark)))) + (line-start point)))))) + + +(defun transpose-lines (mark1 mark2) + (with-mark ((tmark1 mark1)) + (line-offset tmark1 1) + (ninsert-region mark2 (delete-and-save-region (region mark1 tmark1))))) + + + +;;;; -- Utilities -- + +(defun skip-prefix-if-here (mark prefix prefix-length) + (if (and prefix (%line-has-prefix-p mark prefix prefix-length)) + (character-offset mark prefix-length))) + + + +(defun text-blank-line-p (mark) + (let ((next-char (next-character mark))) + (or (blank-after-p mark) + (and (funcall (value paragraph-delimiter-function) mark) + (not (whitespace-attribute-p next-char)))))) + + + +(defun whitespace-attribute-p (char) + (= (character-attribute :whitespace char) 1)) + +(defun sentence-terminator-attribute-p (char) + (= (character-attribute :sentence-terminator char) 1)) + +(defun sentence-closing-char-attribute-p (char) + (= (character-attribute :sentence-closing-char char) 1)) + +(defun paragraph-delimiter-attribute-p (char) + (= (character-attribute :paragraph-delimiter char) 1)) + +(defun word-delimiter-attribute-p (char) + (= (character-attribute :word-delimiter char) 1)) diff --git a/hemlock/ts-stream.lisp b/hemlock/ts-stream.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e14aab70c73c63d36fbe0d9def922b03ca628e5b --- /dev/null +++ b/hemlock/ts-stream.lisp @@ -0,0 +1,283 @@ +;;; -*- Package: Hemlock; Log: hemlock.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; This file implements typescript streams. +;;; +;;; Written by William Lott. +;;; + +(in-package "HEMLOCK") + +(defconstant ts-stream-output-buffer-size 512) + +(defstruct (ts-stream + (:include stream + (in #'%ts-stream-in) + (out #'%ts-stream-out) + (sout #'%ts-stream-sout) + (misc #'%ts-stream-misc)) + (:print-function %ts-stream-print) + (:constructor make-ts-stream (wire typescript))) + wire + typescript + (output-buffer (make-string ts-stream-output-buffer-size) + :type simple-string) + (output-buffer-index 0 :type fixnum) + (char-pos 0) + current-input + (input-read-index 0 :type fixnum)) + +(defun %ts-stream-print (ts stream depth) + (declare (ignore ts depth)) + (write-string "#<TS Stream>" stream)) + +;;; TS-STREAM-ACCEPT-INPUT --- internal interface. +;;; +;;; This routine is called by the editor to indicate that the user has typed +;;; more input. +;;; +(defun ts-stream-accept-input (remote string) + (let ((stream (wire:remote-object-value remote))) + (system:without-interrupts + (setf (ts-stream-current-input stream) + (nconc (ts-stream-current-input stream) + (list string))) + (setf (ts-stream-char-pos stream) 0))) + nil) + +;;; %TS-STREAM-LISTEN --- internal. +;;; +;;; Determine if there is any input available. If we don't think so, process +;;; all pending events, and look again. +;;; +(defun %ts-stream-listen (stream) + (flet ((check () + (system:without-interrupts + (loop + (let ((current (ts-stream-current-input stream))) + (cond ((null current) + (return nil)) + ((>= (ts-stream-input-read-index stream) + (length (the simple-string (car current)))) + (pop (ts-stream-current-input stream)) + (setf (ts-stream-input-read-index stream) 0)) + (t + (return t)))))))) + (or (check) + (progn + (system:serve-all-events 0) + (check))))) + +;;; WAIT-FOR-TYPESCRIPT-INPUT --- internal. +;;; +;;; Keep calling server until some input shows up. +;;; +(defun wait-for-typescript-input (stream) + (unless (%ts-stream-listen stream) + (let ((wire (ts-stream-wire stream)) + (ts (ts-stream-typescript stream))) + (wire:remote wire + (ts-buffer-ask-for-input ts)) + (wire:wire-force-output wire) + (loop + (system:serve-all-events) + (when (%ts-stream-listen stream) + (return)))))) + +;;; %TS-STREAM-IN --- internal. +;;; +;;; The READ-CHAR stream method. +;;; +(defun %ts-stream-in (stream &optional eoferr eofval) + (declare (ignore eoferr eofval)) ; EOF's are impossible. + (wait-for-typescript-input stream) + (system:without-interrupts + (prog1 + (schar (car (ts-stream-current-input stream)) + (ts-stream-input-read-index stream)) + (incf (ts-stream-input-read-index stream))))) + + + +;;; %TS-STREAM-READ-LINE --- internal. +;;; +;;; The READ-LINE stream method. Note: here we take advantage of the fact that +;;; newlines will only appear at the end of strings. +;;; +(defun %ts-stream-read-line (stream eoferr eofval) + (declare (ignore eoferr eofval)) + (macrolet ((next-str () + '(progn + (wait-for-typescript-input stream) + (system:without-interrupts + (prog1 + (if (zerop (ts-stream-input-read-index stream)) + (pop (ts-stream-current-input stream)) + (subseq (pop (ts-stream-current-input stream)) + (ts-stream-input-read-index stream))) + (setf (ts-stream-input-read-index stream) 0)))))) + (do ((result (next-str) (concatenate 'simple-string result (next-str)))) + ((char= (schar result (1- (length result))) #\newline) + (values (subseq result 0 (1- (length result))) + nil)) + (declare (simple-string result))))) + +;;; %TS-STREAM-FLSBUF --- internal. +;;; +;;; Flush the output buffer associated with stream. +;;; +(defun %ts-stream-flsbuf (stream) + (when (and (ts-stream-wire stream) + (ts-stream-output-buffer stream) + (not (zerop (ts-stream-output-buffer-index stream)))) + (wire:remote (ts-stream-wire stream) + (ts-buffer-output-string (ts-stream-typescript stream) + (subseq (the simple-string + (ts-stream-output-buffer stream)) + 0 + (ts-stream-output-buffer-index stream)))) + (setf (ts-stream-output-buffer-index stream) + 0))) + +;;; %TS-STREAM-OUT --- internal. +;;; +;;; Output a single character to stream. +;;; +(defun %ts-stream-out (stream char) + (declare (string-char char)) + (when (= (ts-stream-output-buffer-index stream) + ts-stream-output-buffer-size) + (%ts-stream-flsbuf stream)) + (setf (schar (ts-stream-output-buffer stream) + (ts-stream-output-buffer-index stream)) + char) + (incf (ts-stream-output-buffer-index stream)) + (incf (ts-stream-char-pos stream)) + (when (= (char-code char) + (char-code #\Newline)) + (%ts-stream-flsbuf stream) + (setf (ts-stream-char-pos stream) 0) + (wire:wire-force-output (ts-stream-wire stream))) + char) + +;;; %TS-STREAM-SOUT --- internal. +;;; +;;; Output a string to stream. +;;; +(defun %ts-stream-sout (stream string start end) + (declare (simple-string string)) + (declare (fixnum start end)) + (let ((wire (ts-stream-wire stream)) + (newline (position #\Newline string :start start :end end :from-end t)) + (length (- end start))) + (when wire + (let ((index (ts-stream-output-buffer-index stream))) + (cond ((> (+ index length) + ts-stream-output-buffer-size) + (%ts-stream-flsbuf stream) + (wire:remote wire + (ts-buffer-output-string (ts-stream-typescript stream) + (subseq string start end))) + (when newline + (wire:wire-force-output wire))) + (t + (replace (the simple-string (ts-stream-output-buffer stream)) + string + :start1 index + :end1 (+ index length) + :start2 start + :end2 end) + (incf (ts-stream-output-buffer-index stream) + length) + (when newline + (%ts-stream-flsbuf stream) + (wire:wire-force-output wire)))))) + (setf (ts-stream-char-pos stream) + (if newline + (- end newline 1) + (+ (ts-stream-char-pos stream) + length))))) + +;;; %TS-STREAM-UNREAD --- internal. +;;; +;;; Unread a single character. +;;; +(defun %ts-stream-unread (stream char) + (system:without-interrupts + (cond ((and (ts-stream-current-input stream) + (> (ts-stream-input-read-index stream) 0)) + (setf (schar (car (ts-stream-current-input stream)) + (decf (ts-stream-input-read-index stream))) + char)) + (t + (push (string char) (ts-stream-current-input stream)) + (setf (ts-stream-input-read-index stream) 0))))) + +;;; %TS-STREAM-CLOSE --- internal. +;;; +;;; Can't do much, 'cause the wire is shared. +;;; +(defun %ts-stream-close (stream abort) + (unless abort + (force-output stream)) + (lisp::set-closed-flame stream)) + +;;; %TS-STREAM-CLEAR-INPUT --- internal. +;;; +;;; Pass the request to the editor and clear any buffered input. +;;; +(defun %ts-stream-clear-input (stream) + (when (ts-stream-wire stream) + (wire:remote-value (ts-stream-wire stream) + (ts-buffer-clear-input (ts-stream-typescript stream)))) + (system:without-interrupts + (setf (ts-stream-current-input stream) nil + (ts-stream-input-read-index stream) 0))) + +;;; %TS-STREAM-MISC --- internal. +;;; +;;; The misc stream method. +;;; +(defun %ts-stream-misc (stream operation &optional arg1 arg2) + (case operation + (:read-line + (%ts-stream-read-line stream arg1 arg2)) + (:listen + (%ts-stream-listen stream)) + (:unread + (%ts-stream-unread stream arg1)) + (:close + (%ts-stream-close stream arg1)) + (:clear-input + (%ts-stream-clear-input stream) + t) + (:finish-output + (when (ts-stream-wire stream) + (%ts-stream-flsbuf stream) + ;; Note: for the return value to come back, + ;; all pending RPCs must have completed. + (wire:remote-value (ts-stream-wire stream) + (ts-buffer-finish-output (ts-stream-typescript stream)))) + t) + (:force-output + (when (ts-stream-wire stream) + (%ts-stream-flsbuf stream) + (wire:wire-force-output (ts-stream-wire stream))) + t) + (:clear-output + (setf (ts-stream-output-buffer-index stream) 0) + t) + (:element-type + 'char-string) + (:charpos + (ts-stream-char-pos stream)) + (:line-length + (wire:remote-value (ts-stream-wire stream) + (ts-buffer-line-length (ts-stream-typescript stream)))))) diff --git a/hemlock/tty-disp-rt.lisp b/hemlock/tty-disp-rt.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5bd888dc41f81b391cdfe0e704be19cc7e948889 --- /dev/null +++ b/hemlock/tty-disp-rt.lisp @@ -0,0 +1,139 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles. +;;; + +(in-package "HEMLOCK-INTERNALS") + + +;;;; Terminal init and exit methods. + +(defvar *hemlock-input-handler*) + +(defun init-tty-device (device) + (setf *hemlock-input-handler* + (system:add-fd-handler 0 :input #'get-editor-tty-input)) + (standard-device-init) + (device-write-string (tty-device-init-string device)) + (redisplay-all)) + +(defun exit-tty-device (device) + (cursor-motion device 0 (1- (tty-device-lines device))) + ;; Can't call the clear-to-eol method since we don't have a hunk to + ;; call it on, and you can't count on the bottom hunk being the echo area. + ;; + (if (tty-device-clear-to-eol-string device) + (device-write-string (tty-device-clear-to-eol-string device)) + (dotimes (i (tty-device-columns device) + (cursor-motion device 0 (1- (tty-device-lines device)))) + (tty-write-char #\space))) + (device-write-string (tty-device-cm-end-string device)) + (when (device-force-output device) + (funcall (device-force-output device))) + (when *hemlock-input-handler* + (system:remove-fd-handler *hemlock-input-handler*) + (setf *hemlock-input-handler* nil)) + (standard-device-exit)) + + + +;;;; Output routines and buffering. + +(defconstant redisplay-output-buffer-length 256) + +(defvar *redisplay-output-buffer* + (make-string redisplay-output-buffer-length)) +(proclaim '(simple-string *redisplay-output-buffer*)) + +(defvar *redisplay-output-buffer-index* 0) +(proclaim '(fixnum *redisplay-output-buffer-index*)) + + +;;; TTY-WRITE-STRING blasts the string into the redisplay output buffer. +;;; If the string overflows the buffer, then segments of the string are +;;; blasted into the buffer, dumping the buffer, until the last piece of +;;; the string is stored in the buffer. The buffer is always dumped if +;;; it is full, even if the last piece of the string just fills the buffer. +;;; +(defun tty-write-string (string start length) + (declare (fixnum start length)) + (let ((buffer-space (- redisplay-output-buffer-length + *redisplay-output-buffer-index*))) + (declare (fixnum buffer-space)) + (cond ((<= length buffer-space) + (let ((dst-index (+ *redisplay-output-buffer-index* length))) + (%primitive byte-blt string start *redisplay-output-buffer* + *redisplay-output-buffer-index* dst-index) + (cond ((= length buffer-space) + (mach:unix-write 1 *redisplay-output-buffer* 0 + redisplay-output-buffer-length) + (setf *redisplay-output-buffer-index* 0)) + (t + (setf *redisplay-output-buffer-index* dst-index))))) + (t + (let ((remaining (- length buffer-space))) + (declare (fixnum remaining)) + (loop + (%primitive byte-blt string start *redisplay-output-buffer* + *redisplay-output-buffer-index* + redisplay-output-buffer-length) + (mach:unix-write 1 *redisplay-output-buffer* 0 + redisplay-output-buffer-length) + (when (< remaining redisplay-output-buffer-length) + (%primitive byte-blt string (+ start buffer-space) + *redisplay-output-buffer* 0 remaining) + (setf *redisplay-output-buffer-index* remaining) + (return t)) + (incf start buffer-space) + (setf *redisplay-output-buffer-index* 0) + (setf buffer-space redisplay-output-buffer-length) + (decf remaining redisplay-output-buffer-length))))))) + + +;;; TTY-WRITE-CHAR stores a character in the redisplay output buffer, +;;; dumping the buffer if it becomes full. +;;; +(defun tty-write-char (char) + (setf (schar *redisplay-output-buffer* *redisplay-output-buffer-index*) + char) + (incf *redisplay-output-buffer-index*) + (when (= *redisplay-output-buffer-index* redisplay-output-buffer-length) + (mach:unix-write 1 *redisplay-output-buffer* 0 + redisplay-output-buffer-length) + (setf *redisplay-output-buffer-index* 0))) + + +;;; TTY-FORCE-OUTPUT dumps the redisplay output buffer. This is called +;;; out of terminal device structures in multiple places -- the device +;;; exit method, random typeout methods, out of tty-hunk-stream methods, +;;; after calls to REDISPLAY or REDISPLAY-ALL. +;;; +(defun tty-force-output () + (unless (zerop *redisplay-output-buffer-index*) + (mach:unix-write 1 *redisplay-output-buffer* 0 + *redisplay-output-buffer-index*) + (setf *redisplay-output-buffer-index* 0))) + + +;;; TTY-FINISH-OUTPUT simply dumps output. +;;; +(defun tty-finish-output (device window) + (declare (ignore window)) + (let ((force-output (device-force-output device))) + (when force-output + (funcall force-output)))) + + + +;;;; Screen image line hacks. + +(defmacro replace-si-line (dst-string src-string src-start dst-start dst-end) + `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end)) diff --git a/hemlock/tty-display.lisp b/hemlock/tty-display.lisp new file mode 100644 index 0000000000000000000000000000000000000000..29994d9b5d44ed58e5f528ee3adf33debbb50f11 --- /dev/null +++ b/hemlock/tty-display.lisp @@ -0,0 +1,1102 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Written by Bill Chiles. +;;; + +(in-package "HEMLOCK-INTERNALS") + +(export '(redisplay redisplay-all)) + + + +;;;; Macros. + +(eval-when (compile eval) +(defmacro tty-hunk-modeline-pos (hunk) + `(tty-hunk-text-height ,hunk)) +) ;eval-when + + +(defvar *currently-selected-hunk* nil) +(defvar *hunk-top-line*) + +(proclaim '(fixnum *hunk-top-line*)) + +(eval-when (compile eval) +(defmacro select-hunk (hunk) + `(unless (eq ,hunk *currently-selected-hunk*) + (setf *currently-selected-hunk* ,hunk) + (setf *hunk-top-line* + (the fixnum + (1+ (the fixnum + (- (the fixnum + (tty-hunk-text-position ,hunk)) + (the fixnum + (tty-hunk-text-height ,hunk))))))))) +) ;eval-when + + +;;; Screen image lines. +;;; +(defstruct (si-line (:print-function print-screen-image-line) + (:constructor %make-si-line (chars))) + chars + (length 0)) + +(defun make-si-line (n) + (%make-si-line (make-string n))) + +(defun print-screen-image-line (obj str n) + (declare (ignore n)) + (write-string "#<Screen Image Line \"" str) + (write-string (si-line-chars obj) str :end (si-line-length obj)) + (write-string "\">" str)) + + +(defmacro si-line (screen-image n) + `(svref ,screen-image ,n)) + + + +;;;; Dumb window redisplay. + +(defmacro tty-dumb-line-redisplay (device hunk dis-line &optional y) + (let ((dl (gensym)) (dl-chars (gensym)) (dl-len (gensym)) + (dl-pos (gensym)) (screen-image-line (gensym))) + `(let* ((,dl ,dis-line) + (,dl-chars (dis-line-chars ,dl)) + (,dl-len (dis-line-length ,dl)) + (,dl-pos ,(or y `(dis-line-position ,dl)))) + (funcall (tty-device-display-string ,device) + ,hunk 0 ,dl-pos ,dl-chars 0 ,dl-len) + (setf (dis-line-flags ,dl) unaltered-bits) + (setf (dis-line-delta ,dl) 0) + (select-hunk ,hunk) + (let ((,screen-image-line (si-line (tty-device-screen-image ,device) + (+ *hunk-top-line* ,dl-pos)))) + (replace-si-line (si-line-chars ,screen-image-line) ,dl-chars + 0 0 ,dl-len) + (setf (si-line-length ,screen-image-line) ,dl-len))))) + +(defun tty-dumb-window-redisplay (window) + (let* ((first (window-first-line window)) + (hunk (window-hunk window)) + (device (device-hunk-device hunk)) + (screen-image (tty-device-screen-image device))) + (funcall (tty-device-clear-to-eow device) hunk 0 0) + (do ((i 0 (1+ i)) + (dl (cdr first) (cdr dl))) + ((eq dl the-sentinel) + (setf (window-old-lines window) (1- i)) + (select-hunk hunk) + (do ((last (tty-hunk-text-position hunk)) + (i (+ *hunk-top-line* i) (1+ i))) + ((> i last)) + (declare (fixnum i last)) + (setf (si-line-length (si-line screen-image i)) 0))) + (tty-dumb-line-redisplay device hunk (car dl) i)) + (setf (window-first-changed window) the-sentinel + (window-last-changed window) first) + (when (window-modeline-buffer window) + (let ((dl (window-modeline-dis-line window)) + (y (tty-hunk-modeline-pos hunk))) + (funcall (tty-device-standout-init device) hunk) + (funcall (tty-device-clear-to-eol device) hunk 0 y) + (tty-dumb-line-redisplay device hunk dl y) + (funcall (tty-device-standout-end device) hunk) + (setf (dis-line-flags dl) unaltered-bits))))) + + + +;;;; Dumb redisplay top n lines of a window. + +(defun tty-redisplay-n-lines (window n) + (let* ((hunk (window-hunk window)) + (device (device-hunk-device hunk))) + (funcall (tty-device-clear-lines device) hunk 0 0 n) + (do ((n n (1- n)) + (dl (cdr (window-first-line window)) (cdr dl))) + ((or (zerop n) (eq dl the-sentinel))) + (tty-dumb-line-redisplay device hunk (car dl))))) + + + +;;;; Semi dumb window redisplay + +;;; This is for terminals without opening and deleting lines. + +;;; TTY-SEMI-DUMB-WINDOW-REDISPLAY is a lot like TTY-SMART-WINDOW-REDISPLAY, +;;; but it calls different line redisplay functions. +;;; +(defun tty-semi-dumb-window-redisplay (window) + (let* ((hunk (window-hunk window)) + (device (device-hunk-device hunk))) + (let ((first-changed (window-first-changed window)) + (last-changed (window-last-changed window))) + ;; Is there anything to do? + (unless (eq first-changed the-sentinel) + (if ;; One line-changed. + (and (eq first-changed last-changed) + (zerop (dis-line-delta (car first-changed)))) + (tty-semi-dumb-line-redisplay device hunk (car first-changed)) + ;; More lines changed. + (do-semi-dumb-line-writes first-changed last-changed hunk)) + ;; Set the bounds so we know we displayed... + (setf (window-first-changed window) the-sentinel + (window-last-changed window) (window-first-line window)))) + ;; + ;; Clear any extra lines at the end of the window. + (let ((pos (dis-line-position (car (window-last-line window))))) + (when (< pos (window-old-lines window)) + (tty-smart-clear-to-eow hunk (1+ pos))) + (setf (window-old-lines window) pos)) + ;; + ;; Update the modeline if needed. + (when (window-modeline-buffer window) + (let ((dl (window-modeline-dis-line window))) + (when (/= (dis-line-flags dl) unaltered-bits) + (funcall (tty-device-standout-init device) hunk) + (unwind-protect + (tty-smart-line-redisplay device hunk dl + (tty-hunk-modeline-pos hunk)) + (funcall (tty-device-standout-end device) hunk))))))) + +;;; NEXT-DIS-LINE is used in DO-SEMI-DUMB-LINE-WRITES and +;;; COMPUTE-TTY-CHANGES. +;;; +(eval-when (compile eval) +(defmacro next-dis-line () + `(progn + (setf prev dl) + (setf dl (cdr dl)) + (setf flags (dis-line-flags (car dl))))) +) ;eval-when + +;;; DO-SEMI-DUMB-LINE-WRITES does what it says until it hits the last +;;; changed line. The commented out code was a gratuitous optimization, +;;; especially if the first-changed line really is the first changes line. +;;; Anyway, this had to be removed because of this function's use in +;;; TTY-SMART-WINDOW-REDISPLAY, which was punting line moves due to +;;; "Scroll Redraw Ratio". However, these supposedly moved lines had their +;;; bits set to unaltered bits in COMPUTE-TTY-CHANGES because it was +;;; assuming TTY-SMART-WINDOW-REDISPLAY guaranteed to do line moves. +;;; +(defun do-semi-dumb-line-writes (first-changed last-changed hunk) + (let* ((dl first-changed) + flags ;(dis-line-flags (car dl))) flags bound for NEXT-DIS-LINE. + prev) + (declare (ignore flags)) + ;; + ;; Skip old, unchanged, unmoved lines. + ;; (loop + ;; (unless (zerop flags) (return)) + ;; (next-dis-line)) + ;; + ;; Write every remaining line. + (let* ((device (device-hunk-device hunk)) + (force-output (device-force-output device))) + (loop + (tty-semi-dumb-line-redisplay device hunk (car dl)) + (when force-output (funcall force-output)) + (next-dis-line) + (when (eq prev last-changed) (return)))))) + +;;; TTY-SEMI-DUMB-LINE-REDISPLAY finds the first different character +;;; comparing the display line and the screen image line, writes out the +;;; rest of the display line, and clears to end-of-line as necessary. +;;; +(defun tty-semi-dumb-line-redisplay (device hunk dl + &optional (dl-pos (dis-line-position dl))) + (declare (fixnum dl-pos)) + (let* ((dl-chars (dis-line-chars dl)) + (dl-len (dis-line-length dl))) + (declare (fixnum dl-len) (simple-string dl-chars)) + (when (listen *editor-input*) (throw 'redisplay-catcher :editor-input)) + (select-hunk hunk) + (let* ((screen-image-line (si-line (tty-device-screen-image device) + (+ *hunk-top-line* dl-pos))) + (si-line-chars (si-line-chars screen-image-line)) + (si-line-length (si-line-length screen-image-line)) + (findex (string/= dl-chars si-line-chars + :end1 dl-len :end2 si-line-length))) + (declare (fixnum findex) (simple-string si-line-chars)) + ;; + ;; When the dis-line and screen chars are not string=. + (when findex + (cond + ;; See if the screen shows an initial substring of the dis-line. + ((= findex si-line-length) + (funcall (tty-device-display-string device) + hunk findex dl-pos dl-chars findex dl-len) + (replace-si-line si-line-chars dl-chars findex findex dl-len)) + ;; When the dis-line is an initial substring of what's on the screen. + ((= findex dl-len) + (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)) + ;; Otherwise, blast dl-chars and clear to eol as necessary. + (t (funcall (tty-device-display-string device) + hunk findex dl-pos dl-chars findex dl-len) + (when (< dl-len si-line-length) + (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)) + (replace-si-line si-line-chars dl-chars findex findex dl-len))) + (setf (si-line-length screen-image-line) dl-len))) + (setf (dis-line-flags dl) unaltered-bits) + (setf (dis-line-delta dl) 0))) + + + +;;;; Smart window redisplay -- operation queues and internal screen image. + +;;; This is used for creating temporary smart redisplay structures. +;;; +(defconstant tty-hunk-height-limit 100) + + +;;; Queues for redisplay operations and access macros. +;;; +(defvar *tty-line-insertions* (make-array (* 2 tty-hunk-height-limit))) + +(defvar *tty-line-deletions* (make-array (* 2 tty-hunk-height-limit))) + +(defvar *tty-line-writes* (make-array tty-hunk-height-limit)) + +(eval-when (compile eval) + +(defmacro queue (value queue ptr) + `(progn + (setf (svref ,queue ,ptr) ,value) + (the fixnum (incf (the fixnum ,ptr))))) + +(defmacro dequeue (queue ptr) + `(prog1 + (svref ,queue ,ptr) + (the fixnum (incf (the fixnum ,ptr))))) + +) ;eval-when + +;;; INSERT-LINE-COUNT is used in TTY-SMART-WINDOW-REDISPLAY. The counting is +;;; based on calls to QUEUE in COMPUTE-TTY-CHANGES. +;;; +(defun insert-line-count (ins) + (do ((i 1 (+ i 2)) + (count 0 (+ count (svref *tty-line-insertions* i)))) + ((> i ins) count))) + + +;;; Temporary storage for screen-image lines and accessing macros. +;;; +(defvar *screen-image-temp* (make-array tty-hunk-height-limit)) + +(eval-when (compile eval) + +;;; DELETE-SI-LINES is used in DO-LINE-DELETIONS to simulate what's +;;; happening to the screen in a device's screen-image. At y, num +;;; lines are deleted and saved in *screen-image-temp*; fsil is the +;;; end of the free screen image lines saved here. Also, we must +;;; move lines up in the screen-image structure. In the outer loop +;;; we save lines in the temp storage and move lines up at the same +;;; time. In the termination/inner loop we move any lines that still +;;; need to be moved up. The screen-length is adjusted by the fsil +;;; because any time a deletion is in progress, there are fsil bogus +;;; lines at the bottom of the screen image from lines being moved +;;; up previously. +;;; +(defmacro delete-si-lines (screen-image y num fsil screen-length) + (let ((do-screen-image (gensym)) (delete-index (gensym)) + (free-lines (gensym)) (source-index (gensym)) (target-index (gensym)) + (n (gensym)) (do-screen-length (gensym)) (do-y (gensym))) + `(let ((,do-screen-image ,screen-image) + (,do-screen-length (- ,screen-length fsil)) + (,do-y ,y)) + (declare (fixnum ,do-screen-length ,do-y)) + (do ((,delete-index ,do-y (1+ ,delete-index)) + (,free-lines ,fsil (1+ ,free-lines)) + (,source-index (+ ,do-y ,num) (1+ ,source-index)) + (,n ,num (1- ,n))) + ((zerop ,n) + (do ((,target-index ,delete-index (1+ ,target-index)) + (,source-index ,source-index (1+ ,source-index))) + ((>= ,source-index ,do-screen-length)) + (declare (fixnum ,target-index ,source-index)) + (setf (si-line ,do-screen-image ,target-index) + (si-line ,do-screen-image ,source-index)))) + (declare (fixnum ,delete-index ,free-lines ,source-index ,n)) + (setf (si-line *screen-image-temp* ,free-lines) + (si-line ,do-screen-image ,delete-index)) + (when (< ,source-index ,do-screen-length) + (setf (si-line ,do-screen-image ,delete-index) + (si-line ,do-screen-image ,source-index))))))) + + +;;; INSERT-SI-LINES is used in DO-LINE-INSERTIONS to simulate what's +;;; happening to the screen in a device's screen-image. At y, num free +;;; lines are inserted from *screen-image-temp*; fsil is the end of the +;;; free lines. When copying lines down in screen-image, we must start +;;; with the lower lines and end with the higher ones, so we don't trash +;;; any lines. The outer loop does all the copying, and the termination/ +;;; inner loop inserts the free screen image lines, setting their length +;;; to zero. +;;; +(defmacro insert-si-lines (screen-image y num fsil screen-length) + (let ((do-screen-image (gensym)) (source-index (gensym)) + (target-index (gensym)) (target-terminus (gensym)) + (do-screen-length (gensym)) (temp (gensym)) (do-y (gensym)) + (insert-index (gensym)) (free-lines-index (gensym)) + (n (gensym))) + `(let ((,do-screen-length ,screen-length) + (,do-screen-image ,screen-image) + (,do-y ,y)) + (do ((,target-terminus (1- (+ ,do-y ,num))) ; (1- target-start) + (,source-index (- ,do-screen-length ,fsil 1) ; (1- source-end) + (1- ,source-index)) + (,target-index (- (+ ,do-screen-length ,num) + ,fsil 1) ; (1- target-end) + (1- ,target-index))) + ((= ,target-index ,target-terminus) + (do ((,insert-index ,do-y (1+ ,insert-index)) + (,free-lines-index (1- ,fsil) (1- ,free-lines-index)) + (,n ,num (1- ,n))) + ((zerop ,n)) + (declare (fixnum ,insert-index ,free-lines-index ,n)) + (let ((,temp (si-line *screen-image-temp* ,free-lines-index))) + (setf (si-line-length ,temp) 0) + (setf (si-line ,do-screen-image ,insert-index) ,temp))) + (decf ,fsil ,num)) + (declare (fixnum ,target-terminus ,source-index ,target-index)) + (setf (si-line ,do-screen-image ,target-index) + (si-line ,do-screen-image ,source-index)))))) + +) ;eval-when + + + +;;;; Smart window redisplay -- the function. + +;;; TTY-SMART-WINDOW-REDISPLAY sees if only one line changed after +;;; some preliminary processing. If more than one line changed, +;;; then we compute changes to make to the screen in the form of +;;; line insertions, deletions, and writes. Deletions must be done +;;; first, so lines are not lost off the bottom of the screen by +;;; inserting lines. +;;; +(defun tty-smart-window-redisplay (window) + (let* ((hunk (window-hunk window)) + (device (device-hunk-device hunk))) + (let ((first-changed (window-first-changed window)) + (last-changed (window-last-changed window))) + ;; Is there anything to do? + (unless (eq first-changed the-sentinel) + (if (and (eq first-changed last-changed) + (zerop (dis-line-delta (car first-changed)))) + ;; One line-changed. + (tty-smart-line-redisplay device hunk (car first-changed)) + ;; More lines changed. + (multiple-value-bind (ins outs writes) + (compute-tty-changes + first-changed last-changed + (tty-hunk-modeline-pos hunk)) + (let ((ratio (variable-value 'ed::scroll-redraw-ratio))) + (cond ((and ratio + (> (/ (insert-line-count ins) + (tty-hunk-text-height hunk)) + ratio)) + (do-semi-dumb-line-writes first-changed last-changed + hunk)) + (t + (do-line-insertions hunk ins + (do-line-deletions hunk outs)) + (do-line-writes hunk writes)))))) + ;; Set the bounds so we know we displayed... + (setf (window-first-changed window) the-sentinel + (window-last-changed window) (window-first-line window)))) + ;; + ;; Clear any extra lines at the end of the window. + (let ((pos (dis-line-position (car (window-last-line window))))) + (when (< pos (window-old-lines window)) + (tty-smart-clear-to-eow hunk (1+ pos))) + (setf (window-old-lines window) pos)) + ;; + ;; Update the modeline if needed. + (when (window-modeline-buffer window) + (let ((dl (window-modeline-dis-line window))) + (when (/= (dis-line-flags dl) unaltered-bits) + (funcall (tty-device-standout-init device) hunk) + (unwind-protect + (tty-smart-line-redisplay device hunk dl + (tty-hunk-modeline-pos hunk)) + (funcall (tty-device-standout-end device) hunk))))))) + + + +;;;; Smart window redisplay -- computing changes to the display. + +;;; There is a lot of documentation here to help since this code is not +;;; obviously correct. The code is not that cryptic, but the correctness +;;; of the algorithm is somewhat. Most of the complexity is in handling +;;; lines that moved on the screen which the introduction deals with. +;;; Also, the block of documentation immediately before the function +;;; COMPUTE-TTY-CHANGES has its largest portion dedicated to this part of +;;; the function which is the largest block of code in the function. + +;;; The window image dis-lines are annotated with the difference between +;;; their current intended locations and their previous locations in the +;;; window. This delta (distance moved) is negative for an upward move and +;;; positive for a downward move. To determine what to do with moved +;;; groups of lines, we consider the transition (or difference in deltas) +;;; between two adjacent groups as we look at the window's dis-lines moving +;;; down the window image, disregarding whether they are contiguous (having +;;; moved only by a different delta) or separated by some lines (such as +;;; lines that are new and unmoved). +;;; +;;; Considering the transition between moved groups makes sense because a +;;; given group's delta affects all the lines below it since the dis-lines +;;; reflect the window's buffer's actual lines which are all connected in +;;; series. Therefore, if the previous group moved up some delta number of +;;; lines because of line deletions, then the lines below this group (down +;;; to the last line of the window image) moved up by the same delta too, +;;; unless one of the following is true: +;;; 1] The lines below the group moved up by a greater delta, possibly +;;; due to multiple disjoint buffer line deletions. +;;; 2] The lines below the group moved up by a lesser delta, possibly +;;; due to a number (less than the previous delta) of new line +;;; insertions below the group that moved up. +;;; 3] The lines below the group moved down, possibly due to a number +;;; (greater than the previous delta) of new line insertions below +;;; the group that moved up. +;;; Similarly, if the previous group moved down some delta number of lines +;;; because of new line insertions, then the lines below this group (down +;;; to the last line of the window image not to fall off the window's lower +;;; edge) moved down by the same delta too, unless one of the following is +;;; true: +;;; 1] The lines below the group moved down by a greater delta, possibly +;;; due to multiple disjoint buffer line insertions. +;;; 2] The lines below the group moved down by a lesser delta, possibly +;;; due to a number (less than the previous delta) of line deletions +;;; below the group that moved down. +;;; 3] The lines below the group moved up, possibly due to a number +;;; (greater than the previous delta) of line deletions below the +;;; group that moved down. +;;; +;;; Now we can see how the first moved group affects the window image below +;;; it except where there is a lower group of lines that have moved a +;;; different delta due to separate operations on the buffer's lines viewed +;;; through a window. We can see that this different delta is the expected +;;; effect throughout the window image below the second group, unless +;;; something lower down again has affected the window image. Also, in the +;;; case of a last group of lines that moved up, the group will never +;;; reflect all of the lines in the window image from the first line to +;;; move down to the bottom of the window image because somewhere down below +;;; the group that moved up are some new lines that have just been drawn up +;;; into the window's image. +;;; + +;;; COMPUTE-TTY-CHANGES is used once in TTY-SMART-WINDOW-REDISPLAY. +;;; It goes through all the display lines for a window recording where +;;; lines need to be inserted, deleted, or written to make the screen +;;; consistent with the internal image of the screen. Pointers to +;;; the insertions, deletions, and writes that have to be done are +;;; returned. +;;; +;;; If a line is new, then simply queue it to be written. +;;; +;;; If a line is moved and/or changed, then we compute the difference +;;; between the last block of lines that moved with the same delta and the +;;; current block of lines that moved with the current delta. If this +;;; difference is positive, then some lines need to be deleted. Since we +;;; do all the line deletions first to prevent line insertions from +;;; dropping lines off the bottom of the screen, we have to compute the +;;; position of line deletions using the cumulative insertions +;;; (cum-inserts). Without any insertions, deletions may be done right at +;;; the dis-line's new position. With insertions needed above a given +;;; deletion point combined with the fact that deletions are all done +;;; first, the location for the deletion is higher than it would be without +;;; the insertions being done above the deletions. The location of the +;;; deletion is higher by the number of insertions we have currently put +;;; off. When computing the position of line insertions (a negative delta +;;; transition), we do not need to consider the cumulative insertions or +;;; cumulative deletions since everything above the point of insertion +;;; (both deletions and insertions) has been done. Because of the screen +;;; state being correct above the point of an insertion, the screen is only +;;; off by the delta transition number of lines. After determining the +;;; line insertions or deletions, loop over contiguous lines with the same +;;; delta queuing any changed ones to be written. The delta and flag +;;; fields are initialized according to the need to be written; since +;;; redisplay may be interrupted by more user input after moves have been +;;; done to the screen, we save the changed bit on, so the line will be +;;; queued to be written after redisplay is re-entered. +;;; +;;; If the line is changed or new, then queue it to be written. Note +;;; before that we checked the flags for equality with the new bits, and +;;; it is possible that updating the window image will yield lines that +;;; are both new and changed. +;;; +;;; Otherwise, get the next display line, loop, and see if it's +;;; interesting. +;;; +(defun compute-tty-changes (first-changed last-changed modeline-pos) + (declare (fixnum modeline-pos)) + (let* ((dl first-changed) + (flags (dis-line-flags (car dl))) + (ins 0) (outs 0) (writes 0) + (prev-delta 0) (cum-deletes 0) (net-delta 0) (cum-inserts 0) + prev) + (declare (fixnum flags ins outs writes prev-delta cum-deletes net-delta + cum-inserts)) + (loop + (cond + ((= flags new-bit) + (queue (car dl) *tty-line-writes* writes) + (next-dis-line)) + ((not (zerop (the fixnum (logand flags moved-bit)))) + (let* ((start-dl (car dl)) + (start-pos (dis-line-position start-dl)) + (curr-delta (dis-line-delta start-dl)) + (delta-delta (- prev-delta curr-delta)) + (car-dl start-dl)) + (declare (fixnum start-pos curr-delta delta-delta)) + (cond ((plusp delta-delta) + (queue (the fixnum (- start-pos cum-inserts)) + *tty-line-deletions* outs) + (queue delta-delta *tty-line-deletions* outs) + (incf cum-deletes delta-delta) + (decf net-delta delta-delta)) + ((minusp delta-delta) + (let ((eff-pos (the fixnum (+ start-pos delta-delta))) + (num (the fixnum (- delta-delta)))) + (queue eff-pos *tty-line-insertions* ins) + (queue num *tty-line-insertions* ins) + (incf net-delta num) + (incf cum-inserts num))) + (t (error "Internal error -- unexpected zero transition delta ~ + in redisplay."))) + (loop + (cond ((and (zerop (the fixnum (logand flags changed-bit))) + (zerop (the fixnum (logand flags new-bit)))) + (setf (dis-line-flags car-dl) unaltered-bits)) + (t (queue car-dl *tty-line-writes* writes) + ;; keep just the changed-bit on. + (setf (dis-line-flags car-dl) changed-bit))) + (setf (dis-line-delta car-dl) 0) + (next-dis-line) + (setf car-dl (car dl)) + (when (/= (the fixnum (dis-line-delta car-dl)) curr-delta) + (setf prev-delta curr-delta) + (return))))) + ((not (and (zerop (logand (the fixnum flags) changed-bit)) + (zerop (logand (the fixnum flags) new-bit)))) + (queue (car dl) *tty-line-writes* writes) + (next-dis-line)) + (t (next-dis-line))) + (when (eq prev last-changed) + (unless (zerop net-delta) + (cond ((plusp net-delta) + (queue (the fixnum (- modeline-pos cum-deletes net-delta)) + *tty-line-deletions* outs) + (queue net-delta *tty-line-deletions* outs)) + (t (queue (the fixnum (+ modeline-pos net-delta)) + *tty-line-insertions* ins) + (queue (the fixnum (- net-delta)) + *tty-line-insertions* ins)))) + (return (values ins outs writes)))))) + + + +;;;; Smart window redisplay -- operation methods. + +;;; TTY-SMART-CLEAR-TO-EOW clears lines y through the last text line of hunk. +;;; It takes care not to clear a line unless it really has some characters +;;; displayed on it. It also maintains the device's screen image lines. +;;; +(defun tty-smart-clear-to-eow (hunk y) + (let* ((device (device-hunk-device hunk)) + (screen-image (tty-device-screen-image device)) + (clear-to-eol (tty-device-clear-to-eol device))) + (select-hunk hunk) + (do ((y y (1+ y)) + (si-idx (+ *hunk-top-line* y) (1+ si-idx)) + (last (tty-hunk-text-position hunk))) + ((> si-idx last)) + (declare (fixnum y si-idx last)) + (let ((si-line (si-line screen-image si-idx))) + (unless (zerop (si-line-length si-line)) + (funcall clear-to-eol hunk 0 y) + (setf (si-line-length si-line) 0)))))) + +;;; DO-LINE-DELETIONS pops elements off the *tty-lines-deletions* queue, +;;; deleting lines from hunk's area of the screen. The internal screen +;;; image is updated, and the total number of lines deleted is returned. +;;; +(defun do-line-deletions (hunk outs) + (declare (fixnum outs)) + (let* ((i 0) + (device (device-hunk-device hunk)) + (fun (tty-device-delete-line device)) + (fsil 0)) ;free-screen-image-lines + (declare (fixnum i fsil)) + (loop + (when (= i outs) (return fsil)) + (let ((y (dequeue *tty-line-deletions* i)) + (num (dequeue *tty-line-deletions* i))) + (declare (fixnum y num)) + (funcall fun hunk 0 y num) + (select-hunk hunk) + (delete-si-lines (tty-device-screen-image device) + (+ *hunk-top-line* y) num fsil + (tty-device-lines device)) + (incf fsil num))))) + +;;; DO-LINE-INSERTIONS pops elements off the *tty-line-insertions* queue, +;;; inserting lines into hunk's area of the screen. The internal screen +;;; image is updated using free screen image lines pointed to by fsil. +;;; +(defun do-line-insertions (hunk ins fsil) + (declare (fixnum ins fsil)) + (let* ((i 0) + (device (device-hunk-device hunk)) + (fun (tty-device-open-line device))) + (declare (fixnum i)) + (loop + (when (= i ins) (return)) + (let ((y (dequeue *tty-line-insertions* i)) + (num (dequeue *tty-line-insertions* i))) + (declare (fixnum y num)) + (funcall fun hunk 0 y num) + (select-hunk hunk) + (insert-si-lines (tty-device-screen-image device) + (+ *hunk-top-line* y) num fsil + (tty-device-lines device)))))) + +;;; DO-LINE-WRITES pops elements off the *tty-line-writes* queue, displaying +;;; these dis-lines with TTY-SMART-LINE-REDISPLAY. We force output after +;;; each line, so the user can see how far we've gotten in case he chooses +;;; to give more editor commands which will abort redisplay until there's no +;;; more input. +;;; +(defun do-line-writes (hunk writes) + (declare (fixnum writes)) + (let* ((i 0) + (device (device-hunk-device hunk)) + (force-output (device-force-output device))) + (declare (fixnum i)) + (loop + (when (= i writes) (return)) + (tty-smart-line-redisplay device hunk (dequeue *tty-line-writes* i)) + (when force-output (funcall force-output))))) + +;;; TTY-SMART-LINE-REDISPLAY uses an auxiliary screen image structure to +;;; try to do minimal character shipping to the terminal. Roughly, we find +;;; the first different character when comparing what's on the screen and +;;; what should be there; we will start altering the line after this same +;;; initial substring. Then we find, from the end, the first character +;;; that is different, blasting out characters to the lesser of the two +;;; indexes. If the dis-line index is lesser, we have some characters to +;;; delete from the screen, and if the screen index is lesser, we have some +;;; additional dis-line characters to insert. There are a few special +;;; cases that allow us to punt out of the above algorithm sketch. If the +;;; terminal doesn't have insert mode or delete mode, we have blast out to +;;; the end of the dis-line and possibly clear to the end of the screen's +;;; line, as appropriate. Sometimes we don't use insert or delete mode +;;; because of the overhead cost in characters; it simply is cheaper to +;;; blast out characters and clear to eol. +;;; +(defun tty-smart-line-redisplay (device hunk dl + &optional (dl-pos (dis-line-position dl))) + (declare (fixnum dl-pos)) + (let* ((dl-chars (dis-line-chars dl)) + (dl-len (dis-line-length dl))) + (declare (fixnum dl-len) (simple-string dl-chars)) + (when (listen *editor-input*) (throw 'redisplay-catcher :editor-input)) + (select-hunk hunk) + (let* ((screen-image-line (si-line (tty-device-screen-image device) + (+ *hunk-top-line* dl-pos))) + (si-line-chars (si-line-chars screen-image-line)) + (si-line-length (si-line-length screen-image-line)) + (findex (string/= dl-chars si-line-chars + :end1 dl-len :end2 si-line-length))) + (declare (fixnum findex) (simple-string si-line-chars)) + ;; + ;; When the dis-line and screen chars are not string=. + (when findex + (block tslr-main-body + ;; + ;; See if the screen shows an initial substring of the dis-line. + (when (= findex si-line-length) + (funcall (tty-device-display-string device) + hunk findex dl-pos dl-chars findex dl-len) + (replace-si-line si-line-chars dl-chars findex findex dl-len) + (return-from tslr-main-body t)) + ;; + ;; When the dis-line is an initial substring of what's on the screen. + (when (= findex dl-len) + (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos) + (return-from tslr-main-body t)) + ;; + ;; Find trailing substrings that are the same. + (multiple-value-bind (sindex dindex) + (do ((sindex (1- si-line-length) (1- sindex)) + (dindex (1- dl-len) (1- dindex))) + ((or (= sindex -1) + (= dindex -1) + (char/= (schar dl-chars dindex) + (schar si-line-chars sindex))) + (values (1+ sindex) (1+ dindex)))) + (declare (fixnum sindex dindex)) + ;; + ;; No trailing substrings -- blast and clear to eol. + (when (= dindex dl-len) + (funcall (tty-device-display-string device) + hunk findex dl-pos dl-chars findex dl-len) + (when (< dindex sindex) + (funcall (tty-device-clear-to-eol device) + hunk dl-len dl-pos)) + (replace-si-line si-line-chars dl-chars findex findex dl-len) + (return-from tslr-main-body t)) + (let ((lindex (min sindex dindex))) + (cond ((< lindex findex) + ;; This can happen in funny situations -- believe me! + (setf lindex findex)) + (t + (funcall (tty-device-display-string device) + hunk findex dl-pos dl-chars findex lindex) + (replace-si-line si-line-chars dl-chars + findex findex lindex))) + (cond + ((= dindex sindex)) + ((< dindex sindex) + (let ((delete-char-num (- sindex dindex))) + (cond ((and (tty-device-delete-char device) + (worth-using-delete-mode + device delete-char-num (- si-line-length dl-len))) + (funcall (tty-device-delete-char device) + hunk dindex dl-pos delete-char-num)) + (t + (funcall (tty-device-display-string device) + hunk dindex dl-pos dl-chars dindex dl-len) + (funcall (tty-device-clear-to-eol device) + hunk dl-len dl-pos))))) + (t + (if (and (tty-device-insert-string device) + (worth-using-insert-mode device (- dindex sindex))) + (funcall (tty-device-insert-string device) + hunk sindex dl-pos dl-chars sindex dindex) + (funcall (tty-device-display-string device) + hunk sindex dl-pos dl-chars sindex dl-len)))) + (replace-si-line si-line-chars dl-chars + lindex lindex dl-len)))) + (setf (si-line-length screen-image-line) dl-len))) + (setf (dis-line-flags dl) unaltered-bits) + (setf (dis-line-delta dl) 0))) + + + +;;;; Device methods + +;;; Initializing and exiting the device (DEVICE-INIT and DEVICE-EXIT functions). +;;; These can be found in Tty-Display-Rt.Lisp. + + +;;; Clearing the device (DEVICE-CLEAR functions). + +(defun clear-device (device) + (device-write-string (tty-device-clear-string device)) + (cursor-motion device 0 0) + (setf (tty-device-cursor-x device) 0) + (setf (tty-device-cursor-y device) 0)) + + +;;; Moving the cursor around (DEVICE-PUT-CURSOR) + +;;; TTY-PUT-CURSOR makes sure the coordinates are mapped from the hunk's +;;; axis to the screen's and determines the minimal cost cursor motion +;;; sequence. Currently, it does no cost analysis of relative motion +;;; compared to absolute motion but simply makes sure the cursor isn't +;;; already where we want it. +;;; +(defun tty-put-cursor (hunk x y) + (declare (fixnum x y)) + (select-hunk hunk) + (let ((y (the fixnum (+ *hunk-top-line* y))) + (device (device-hunk-device hunk))) + (declare (fixnum y)) + (unless (and (= (the fixnum (tty-device-cursor-x device)) x) + (= (the fixnum (tty-device-cursor-y device)) y)) + (cursor-motion device x y) + (setf (tty-device-cursor-x device) x) + (setf (tty-device-cursor-y device) y)))) + +;;; UPDATE-CURSOR is used in device redisplay methods to make sure the +;;; cursor is where it should be. +;;; +(eval-when (compile eval) + (defmacro update-cursor (hunk x y) + `(funcall (device-put-cursor (device-hunk-device ,hunk)) ,hunk ,x ,y)) +) ;eval-when + +;;; CURSOR-MOTION takes two coordinates on the screen's axis, +;;; moving the cursor to that location. X is the column index, +;;; and y is the line index, but Unix and Termcap believe that +;;; the default order of indexes is first the line and then the +;;; column or (y,x). Because of this, when reversep is non-nil, +;;; we send first x and then y. +;;; +(defun cursor-motion (device x y) + (let ((x-add-char (tty-device-cm-x-add-char device)) + (y-add-char (tty-device-cm-y-add-char device)) + (x-condx-add (tty-device-cm-x-condx-char device)) + (y-condx-add (tty-device-cm-y-condx-char device)) + (one-origin (tty-device-cm-one-origin device))) + (when x-add-char (incf x x-add-char)) + (when (and x-condx-add (> x x-condx-add)) + (incf x (tty-device-cm-x-condx-add-char device))) + (when y-add-char (incf y y-add-char)) + (when (and y-condx-add (> y y-condx-add)) + (incf y (tty-device-cm-y-condx-add-char device))) + (when one-origin (incf x) (incf y))) + (device-write-string (tty-device-cm-string1 device)) + (let ((reversep (tty-device-cm-reversep device)) + (x-pad (tty-device-cm-x-pad device)) + (y-pad (tty-device-cm-y-pad device))) + (if reversep + (cm-output-coordinate x x-pad) + (cm-output-coordinate y y-pad)) + (device-write-string (tty-device-cm-string2 device)) + (if reversep + (cm-output-coordinate y y-pad) + (cm-output-coordinate x x-pad)) + (device-write-string (tty-device-cm-string3 device)))) + +;;; CM-OUTPUT-COORDINATE outputs the coordinate with respect to the pad. If +;;; there is a pad, then the coordinate needs to be sent as digit-char's (for +;;; each digit in the coordinate), and if there is no pad, the coordinate needs +;;; to be converted into a character. Using CODE-CHAR here is not really +;;; portable. With a pad, the coordinate buffer is filled from the end as we +;;; truncate the coordinate by 10, generating ones digits. +;;; +(defconstant cm-coordinate-buffer-len 5) +(defvar *cm-coordinate-buffer* (make-string cm-coordinate-buffer-len)) +;;; +(defun cm-output-coordinate (coordinate pad) + (cond (pad + (let ((i (1- cm-coordinate-buffer-len))) + (loop + (when (= i -1) (error "Terminal has too many lines!")) + (multiple-value-bind (tens ones) + (truncate coordinate 10) + (setf (schar *cm-coordinate-buffer* i) (digit-char ones)) + (when (zerop tens) + (dotimes (n (- pad (- cm-coordinate-buffer-len i))) + (decf i) + (setf (schar *cm-coordinate-buffer* i) #\0)) + (device-write-string *cm-coordinate-buffer* i + cm-coordinate-buffer-len) + (return)) + (decf i) + (setf coordinate tens))))) + (t (tty-write-char (code-char coordinate))))) + + +;;; Writing strings (TTY-DEVICE-DISPLAY-STRING functions) + +;;; DISPLAY-STRING is used to put a string at (x,y) on the device. +;;; +(defun display-string (hunk x y string + &optional (start 0) (end (strlen string))) + (declare (fixnum x y start end)) + (update-cursor hunk x y) + (device-write-string string start end) + (setf (tty-device-cursor-x (device-hunk-device hunk)) + (the fixnum (+ x (the fixnum (- end start)))))) + +;;; DISPLAY-STRING-CHECKING-UNDERLINES is used for terminals that special +;;; case underlines doing an overstrike when they don't otherwise overstrike. +;;; Note: we do not know in this code whether the terminal can backspace (or +;;; what the sequence is), whether the terminal has insert-mode, or whether +;;; the terminal has delete-mode. +;;; +(defun display-string-checking-underlines (hunk x y string + &optional (start 0) + (end (strlen string))) + (declare (fixnum x y start end) (simple-string string)) + (update-cursor hunk x y) + (let ((upos (position #\_ string :test #'char= :start start :end end)) + (device (device-hunk-device hunk))) + (if upos + (let ((previous start) + after-pos) + (declare (fixnum previous after-pos)) + (loop (device-write-string string previous upos) + (setf after-pos (do ((i (1+ upos) (1+ i))) + ((or (= i end) + (char/= (schar string i) #\_)) i) + (declare (fixnum i)))) + (let ((ulen (the fixnum (- after-pos upos))) + (cursor-x (the fixnum (+ x (the fixnum + (- after-pos start)))))) + (declare (fixnum ulen)) + (dotimes (i ulen) (tty-write-char #\space)) + (setf (tty-device-cursor-x device) cursor-x) + (update-cursor hunk upos y) + (dotimes (i ulen) (tty-write-char #\_)) + (setf (tty-device-cursor-x device) cursor-x)) + (setf previous after-pos) + (setf upos (position #\_ string :test #'char= + :start previous :end end)) + (unless upos + (device-write-string string previous end) + (return)))) + (device-write-string string start end)) + (setf (tty-device-cursor-x device) + (the fixnum (+ x (the fixnum (- end start))))))) + + +;;; DEVICE-WRITE-STRING is used to shove a string at the terminal regardless +;;; of cursor position. +;;; +(defun device-write-string (string &optional (start 0) (end (strlen string))) + (declare (fixnum start end)) + (unless (= start end) + (tty-write-string string start (the fixnum (- end start))))) + + +;;; Clearing lines (TTY-DEVICE-CLEAR-TO-EOL, DEVICE-CLEAR-LINES, and +;;; TTY-DEVICE-CLEAR-TO-EOW functions.) + +(defun clear-to-eol (hunk x y) + (update-cursor hunk x y) + (device-write-string + (tty-device-clear-to-eol-string (device-hunk-device hunk)))) + +(defun space-to-eol (hunk x y) + (declare (fixnum x)) + (update-cursor hunk x y) + (let* ((device (device-hunk-device hunk)) + (num (- (the fixnum (tty-device-columns device)) + x))) + (declare (fixnum num)) + (dotimes (i num) (tty-write-char #\space)) + (setf (tty-device-cursor-x device) (+ x num)))) + +(defun clear-lines (hunk x y n) + (let* ((device (device-hunk-device hunk)) + (clear-to-eol (tty-device-clear-to-eol device))) + (funcall clear-to-eol hunk x y) + (do ((y (1+ y) (1+ y)) + (count (1- n) (1- count))) + ((zerop count) + (setf (tty-device-cursor-x device) 0) + (setf (tty-device-cursor-y device) (1- y))) + (declare (fixnum count y)) + (funcall clear-to-eol hunk 0 y)))) + +(defun clear-to-eow (hunk x y) + (declare (fixnum x y)) + (funcall (tty-device-clear-lines (device-hunk-device hunk)) + hunk x y + (the fixnum (- (the fixnum (tty-hunk-text-height hunk)) y)))) + + +;;; Opening and Deleting lines (TTY-DEVICE-OPEN-LINE and TTY-DEVICE-DELETE-LINE) + +(defun open-tty-line (hunk x y &optional (n 1)) + (update-cursor hunk x y) + (dotimes (i n) + (device-write-string (tty-device-open-line-string (device-hunk-device hunk))))) + +(defun delete-tty-line (hunk x y &optional (n 1)) + (update-cursor hunk x y) + (dotimes (i n) + (device-write-string (tty-device-delete-line-string (device-hunk-device hunk))))) + + +;;; Insert and Delete modes (TTY-DEVICE-INSERT-STRING and TTY-DEVICE-DELETE-CHAR) + +(defun tty-insert-string (hunk x y string + &optional (start 0) (end (strlen string))) + (declare (fixnum x y start end)) + (update-cursor hunk x y) + (let* ((device (device-hunk-device hunk)) + (init-string (tty-device-insert-init-string device)) + (char-init-string (tty-device-insert-char-init-string device)) + (cis-len (if char-init-string (length char-init-string))) + (char-end-string (tty-device-insert-char-end-string device)) + (ces-len (if char-end-string (length char-end-string))) + (end-string (tty-device-insert-end-string device))) + (declare (simple-string char-init-string char-end-string)) + (when init-string (device-write-string init-string)) + (if char-init-string + (do ((i start (1+ i))) + ((= i end)) + (device-write-string char-init-string 0 cis-len) + (tty-write-char (schar string i)) + (when char-end-string + (device-write-string char-end-string 0 ces-len))) + (device-write-string string start end)) + (when end-string (device-write-string end-string)) + (setf (tty-device-cursor-x device) + (the fixnum (+ x (the fixnum (- end start))))))) + +(defun worth-using-insert-mode (device insert-char-num) + (let* ((init-string (tty-device-insert-init-string device)) + (char-init-string (tty-device-insert-char-init-string device)) + (char-end-string (tty-device-insert-char-end-string device)) + (end-string (tty-device-insert-end-string device)) + (cost 0)) + (when init-string (incf cost (length (the simple-string init-string)))) + (when char-init-string + (incf cost (* insert-char-num (+ (length (the simple-string + char-init-string)) + (if char-end-string + (length (the simple-string + char-end-string)) + 0))))) + (when end-string (incf cost (length (the simple-string end-string)))) + (< cost insert-char-num))) + +(defun delete-char (hunk x y &optional n) + (declare (fixnum x y n)) + (update-cursor hunk x y) + (let* ((device (device-hunk-device hunk)) + (init-string (tty-device-delete-init-string device)) + (end-string (tty-device-delete-end-string device)) + (delete-char-string (tty-device-delete-char-string device))) + (when init-string (device-write-string init-string)) + (dotimes (i n) + (device-write-string delete-char-string)) + (when end-string (device-write-string end-string)))) + +(defun worth-using-delete-mode (device delete-char-num clear-char-num) + (declare (fixnum num)) + (let ((init-string (tty-device-delete-init-string device)) + (end-string (tty-device-delete-end-string device)) + (delete-char-string (tty-device-delete-char-string device)) + (clear-to-eol-string (tty-device-clear-to-eol-string device)) + (cost 0)) + (declare (simple-string init-string end-string delete-char-string) + (fixnum cost)) + (when init-string (incf cost (the fixnum (length init-string)))) + (when end-string (incf cost (the fixnum (length end-string)))) + (incf cost (the fixnum + (* (the fixnum (length delete-char-string)) + delete-char-num))) + (< cost (+ delete-char-num + (if clear-to-eol-string + (length clear-to-eol-string) + clear-char-num))))) + + +;;; Standout mode (TTY-DEVICE-STANDOUT-INIT and TTY-DEVICE-STANDOUT-END) + +(defun standout-init (hunk) + (device-write-string + (tty-device-standout-init-string (device-hunk-device hunk)))) + +(defun standout-end (hunk) + (device-write-string + (tty-device-standout-end-string (device-hunk-device hunk)))) diff --git a/hemlock/tty-stream.lisp b/hemlock/tty-stream.lisp new file mode 100644 index 0000000000000000000000000000000000000000..84b1781bf4cd0c52313a996b77d21d50540f008f --- /dev/null +++ b/hemlock/tty-stream.lisp @@ -0,0 +1,157 @@ +;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; Spice Lisp is currently incomplete and under active development. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Some stuff to make streams that write out to terminal hunks. +;;; +;;; Written by Bill Chiles. +;;; +;;; This code is VERY similar to that in Pane-Stream.Lisp. The biggest +;;; (if only) difference is in TTY-HUNK-STREAM-NEWLINE. +;;; + +(in-package 'hemlock-internals) + + + +;;;; Constants + +(defconstant tty-hunk-width-limit 200) + + + +;;;; Structures + +;;; Tty-Hunk streams are inherently buffered by line. + +(defstruct (stream-hunk (:print-function %print-device-hunk) + (:include tty-hunk)) + (width 0 :type fixnum) + (point-x 0 :type fixnum) + (point-y 0 :type fixnum) + (buffer "" :type simple-string)) + +(defstruct (tty-hunk-output-stream (:include stream + (out #'hunk-out) + (sout #'hunk-sout) + (misc #'hunk-misc)) + (:constructor + make-tty-hunk-output-stream ())) + (hunk (make-stream-hunk :buffer (make-string tty-hunk-width-limit)))) + + + +;;;; Tty-hunk-output-stream methods + +;;; HUNK-OUT puts a character into a hunk-stream buffer. If the character +;;; makes the current line wrap, or if the character is a newline, then +;;; call TTY-HUNK-NEWLINE. +;;; +(defun hunk-out (stream character) + (let* ((hunk (tty-hunk-output-stream-hunk stream)) + (x (stream-hunk-point-x hunk))) + (declare (fixnum x)) + (cond ((char= character #\newline) + (tty-hunk-stream-newline hunk) + (return-from hunk-out nil)) + ((= x (the fixnum (stream-hunk-width hunk))) + (setf x 0) + (tty-hunk-stream-newline hunk))) + (setf (schar (stream-hunk-buffer hunk) x) character) + (incf (stream-hunk-point-x hunk)))) + +;;; HUNK-MISC, when finishing or forcing output, only needs to blast +;;; out the buffer at y from 0 to x since these streams are inherently +;;; line buffered. Currently, these characters will be blasted out again +;;; since there isn't a separate buffer index from point-x, and we can't +;;; set point-x to zero since we haven't a newline. +;;; +(defun hunk-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:charpos + (let ((hunk (tty-hunk-output-stream-hunk stream))) + (values (stream-hunk-point-x hunk) (stream-hunk-point-y hunk)))) + ((:finish-output :force-output) + (let* ((hunk (tty-hunk-output-stream-hunk stream)) + (device (device-hunk-device hunk))) + (funcall (tty-device-display-string device) + hunk 0 (stream-hunk-point-y hunk) (stream-hunk-buffer hunk) + 0 (stream-hunk-point-x hunk)) + (when (device-force-output device) + (funcall (device-force-output device))))) + (:line-length + (stream-hunk-width (tty-hunk-output-stream-hunk stream))) + (:element-type 'string-char))) + +;;; HUNK-SOUT writes a byte-blt's a string to a hunk-stream's buffer. +;;; When newlines are found, recurse on the substrings delimited by start, +;;; end, and newlines. If the string causes line wrapping, then we break +;;; the string up into line-at-a-time segments calling TTY-HUNK-STREAM-NEWLINE. +;;; +(defun hunk-sout (stream string start end) + (declare (fixnum start end)) + (let* ((hunk (tty-hunk-output-stream-hunk stream)) + (buffer (stream-hunk-buffer hunk)) + (x (stream-hunk-point-x hunk)) + (dst-end (+ x (- end start))) + (width (stream-hunk-width hunk)) + (newlinep (%sp-find-character string start end #\newline))) + (declare (fixnum x dst-end width)) + (cond (newlinep + (let ((previous start) (current newlinep)) + (declare (fixnum previous)) + (loop (when (null current) + (hunk-sout stream string previous end) + (return)) + (hunk-sout stream string previous current) + (tty-hunk-stream-newline hunk) + (setf previous (the fixnum (1+ (the fixnum current)))) + (setf current + (%sp-find-character string previous end #\newline))))) + ((> dst-end width) + (let ((new-start (+ start (- width x)))) + (declare (fixnum new-start)) + (%primitive byte-blt string start buffer x width) + (setf (stream-hunk-point-x hunk) width) + (tty-hunk-stream-newline hunk) + (do ((idx (+ new-start width) (+ idx width)) + (prev new-start idx)) + ((>= idx end) + (let ((dst-end (- end prev))) + (%primitive byte-blt string prev buffer 0 dst-end) + (setf (stream-hunk-point-x hunk) dst-end))) + (declare (fixnum prev idx)) + (%primitive byte-blt string prev buffer 0 width) + (setf (stream-hunk-point-x hunk) width) + (tty-hunk-stream-newline hunk)))) + (t + (%primitive byte-blt string start buffer x dst-end) + (setf (stream-hunk-point-x hunk) dst-end))))) + +;;; TTY-HUNK-STREAM-NEWLINE is the only place we display lines and affect +;;; point-y. We also blast out the buffer in HUNK-MISC. +;;; +(defun tty-hunk-stream-newline (hunk) + (let* ((device (device-hunk-device hunk)) + (force-output-fun (device-force-output device)) + (y (stream-hunk-point-y hunk))) + (declare (fixnum y)) + (when (= y (the fixnum (device-hunk-position hunk))) + (funcall (tty-device-display-string device) hunk 0 y "--More--" 0 8) + (when force-output-fun (funcall force-output-fun)) + (wait-for-more) + (funcall (tty-device-clear-to-eow device) hunk 0 0) + (setf (stream-hunk-point-y hunk) 0) + (setf y 0)) + (funcall (tty-device-display-string device) + hunk 0 y (stream-hunk-buffer hunk) 0 (stream-hunk-point-x hunk)) + (when force-output-fun (funcall force-output-fun)) + (setf (stream-hunk-point-x hunk) 0) + (incf (stream-hunk-point-y hunk)))) diff --git a/tools/hemcom.lisp b/tools/hemcom.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e8ccd4b874fae984767396c89460106337c5f4fa --- /dev/null +++ b/tools/hemcom.lisp @@ -0,0 +1,149 @@ +;;; +;;; This file compiles all of Hemlock. +;;; + +(when (ext:get-command-line-switch "slave") + (error "Cannot compile Hemlock in a slave due to its clobbering needed + typescript routines by renaming the package.")) + + +;;; Blast the old packages in case they are around. We do this solely to +;;; prove Hemlock can compile cleanly without its having to exist already. +;;; +(when (find-package "ED") + (rename-package (find-package "ED") "OLD-ED")) +;;; +(when (find-package "HI") + (rename-package (find-package "HI") "OLD-HI")) + + +;;; Stuff to set up the packages Hemlock uses. +;;; +(in-package "HEMLOCK-INTERNALS" + :nicknames '("HI") + :use '("LISP" "EXTENSIONS" "SYSTEM")) +;;; +(in-package "HEMLOCK" + :nicknames '("ED") + :use '("LISP" "HEMLOCK-INTERNALS" "EXTENSIONS" "SYSTEM")) +;;; +(in-package "SYSTEM") +(export '(%sp-byte-blt %sp-find-character %sp-find-character-with-attribute + %sp-reverse-find-character-with-attribute)) + +(in-package "HEMLOCK-INTERNALS") + + +(pushnew :command-bits *features*) +(pushnew :buffered-lines *features*) + +(defparameter the-log-file "hem:lossage.log") + +(when (probe-file the-log-file) + (delete-file the-log-file)) + +(defun cf (file) + (write-line file) + (finish-output nil) + (let ((*error-output* (open the-log-file + :direction :output + :if-exists :append + :if-does-not-exist :create))) + (unwind-protect + (progn + (compile-file file :error-file nil) + (terpri *error-output*) (terpri *error-output*)) + (close *error-output*)))) + +(cf "hem:struct.lisp") +(cf "hem:struct-ed.lisp") +(cf "hem:rompsite.lisp") +(cf "hem:charmacs.lisp") +;; keytran and keytrandefs used to be in rompsite, but they are too big now. +;; They also need to go after charmacs due to the funny characters named. +(cf "hem:keytran.lisp") +(cf "hem:keytrandefs.lisp") +(cf "hem:macros.lisp") +(cf "hem:line.lisp") +(cf "hem:ring.lisp") +(cf "hem:table.lisp") +(cf "hem:htext1.lisp") +(cf "hem:htext2.lisp") +(cf "hem:htext3.lisp") +(cf "hem:htext4.lisp") +(cf "hem:search1.lisp") +(cf "hem:search2.lisp") +(cf "hem:linimage.lisp") +(cf "hem:cursor.lisp") +(cf "hem:syntax.lisp") +(cf "hem:winimage.lisp") +(cf "hem:hunk-draw.lisp") +;(cf "hem:bit-stream.lisp") +(cf "hem:termcap.lisp") +(cf "hem:display.lisp") +(cf "hem:bit-display.lisp") +(cf "hem:tty-disp-rt.lisp") +(cf "hem:tty-display.lisp") +;(cf "hem:tty-stream.lisp") +(cf "hem:pop-up-stream.lisp") +(cf "hem:screen.lisp") +(cf "hem:bit-screen.lisp") +(cf "hem:tty-screen.lisp") +(cf "hem:window.lisp") +(cf "hem:font.lisp") +(cf "hem:interp.lisp") +(cf "hem:vars.lisp") +(cf "hem:buffer.lisp") +(cf "hem:files.lisp") +(cf "hem:streams.lisp") +(cf "hem:echo.lisp") +(cf "hem:main.lisp") +(cf "hem:echocoms.lisp") +(cf "hem:defsyn.lisp") +(cf "hem:command.lisp") +(cf "hem:morecoms.lisp") +(cf "hem:undo.lisp") +(cf "hem:killcoms.lisp") +(cf "hem:searchcoms.lisp") +(cf "hem:filecoms.lisp") +(cf "hem:indent.lisp") +(cf "hem:lispmode.lisp") +(cf "hem:comments.lisp") +(cf "hem:fill.lisp") +(cf "hem:text.lisp") +(cf "hem:doccoms.lisp") +(cf "hem:srccom.lisp") +(cf "hem:group.lisp") +(cf "hem:spell-rt.lisp") +(cf "hem:spell-corr.lisp") +(cf "hem:spell-aug.lisp") +(cf "hem:spell-build.lisp") +(cf "hem:spellcoms.lisp") +(cf "hem:abbrev.lisp") +(cf "hem:overwrite.lisp") +(cf "hem:gosmacs.lisp") +(cf "hem:ts-buf.lisp") +(cf "hem:ts-stream.lisp") +(cf "hem:eval-server.lisp") +(cf "hem:lispbuf.lisp") +(cf "hem:lispeval.lisp") +(cf "hem:kbdmac.lisp") +(cf "hem:icom.lisp") +(cf "hem:hi-integrity.lisp") +(cf "hem:ed-integrity.lisp") +(cf "hem:scribe.lisp") +(cf "hem:pascal.lisp") +(cf "hem:edit-defs.lisp") +(cf "hem:auto-save.lisp") +(cf "hem:register.lisp") +(cf "hem:xcoms.lisp") +(cf "hem:unixcoms.lisp") +(cf "hem:mh.lisp") +(cf "hem:highlight.lisp") +(cf "hem:dired.lisp") +(cf "hem:diredcoms.lisp") +(cf "hem:bufed.lisp") +(cf "hem:lisp-lib.lisp") +(cf "hem:completion.lisp") +(cf "hem:shell.lisp") +(cf "hem:bindings.lisp")