;;; lispm.el --- useful Lisp Machine hacks for Emacs
;; ---!!! This assumes a converted Lisp Machine file; on the Lisp
;; ---!!! Machine #o011 (TAB), #o12 (LF) and #o14 (FF) are actual
;; ---!!! characters and do not map back to ASCII. This is why the
;; ---!!! gamma, delta, plus-minus etc symbols are handled
;; ---!!! specially.
(defvar lispm-prettify-symbols-alist
(flet ((x (lm unicode-name) (cons (string lm) (char-from-name unicode-name))))
(list
(x #o000 "MIDDLE DOT") ; 000 center-dot
(x #o001 "DOWNWARDS ARROW") ; 001 down arrow
(x #o002 "GREEK SMALL LETTER ALPHA") ; 002 alpha
(x #o003 "GREEK SMALL LETTER BETA") ; 003 beta
(x #o004 "LOGICAL AND") ; 004 and-sign
(x #o005 "NOT SIGN") ; 005 not-sign
(x #o006 "GREEK SMALL LETTER EPSILON") ; 006 epsilon
(x #o007 "GREEK SMALL LETTER PI") ; 007 pi
(x #o210 "GREEK SMALL LETTER LAMDA") ; 010 lambda
(x #o211 "GREEK SMALL LETTER GAMMA") ; 011 gamma
(x #o212 "GREEK SMALL LETTER DELTA") ; 012 delta
(x #o213 "UPWARDS ARROW") ; 013 uparrow
(x #o214 "PLUS-MINUS SIGN") ; 014 plus-minus
(x #o215 "CIRCLED PLUS") ; 015 circle-plus
(x #o016 "INFINITY") ; 016 infinity
(x #o017 "PARTIAL DIFFERENTIAL") ; 017 partial delta
(x #o020 "SUBSET OF") ; 020 left horseshoe
(x #o021 "SUPERSET OF") ; 021 right horseshoe
(x #o022 "INTERSECTION") ; 022 up horseshoe
(x #o023 "UNION") ; 023 down horseshoe
(x #o024 "FOR ALL") ; 024 universal quantifier
(x #o025 "THERE EXISTS") ; 025 existential quantifier
(x #o026 "CIRCLED TIMES") ; 026 circle-X
(x #o027 "LEFT RIGHT ARROW") ; 027 double-arrow
(x #o030 "LEFTWARDS ARROW") ; 030 left arrow
(x #o031 "RIGHTWARDS ARROW") ; 031 right arrow
(x #o032 "NOT EQUAL TO") ; 032 not-equals
(x #o033 "LOZENGE") ; 033 diamond (altmode)
(x #o034 "LESS-THAN OR EQUAL TO") ; 034 less-or-equal
(x #o035 "GREATER-THAN OR EQUAL TO") ; 035 greater-or-equal
(x #o036 "IDENTICAL TO") ; 036 equivalence
(x #o037 "LOGICAL OR") ; 037 or
;; (x #o177 ...) ; 177
;; (x #o200 ...) ; 200 Null character
;; (x #o201 ...) ; 201 Break
;; (x #o202 ...) ; 202 Clear
;; (x #o203 ...) ; 203 Call
;; (x #o204 ...) ; 204 Terminal escape
;; (x #o205 ...) ; 205 Macro/backnext
;; (x #o206 ...) ; 206 Help
;; (x #o207 ...) ; 207 Rubout
;; (x #o10 ...) ; 210 Overstrike
;; (x #o11 "CHARACTER TABULATION") ; 211 Tab
;; (x #o12 ...) ; 212 Line
;; (x #o13 ...) ; 213 Delete
;; (x #o14 "FORM FEED (FF)") ; 214 Page
;; (x #o15 "LINE FEED (LF)") ; 215 Return
;; (x #o16 ...) ; 216 Quote
;; (x #o17 ...) ; 217 Hold-output
;; (x #o20 ...) ; 220 Stop-output
;; (x #o221 ...) ; 221 Abort
;; (x #o222 ...) ; 222 Resume
;; (x #o223 ...) ; 223 Status
;; (x #o224 ...) ; 224 End
;; (x #o225 ...) ; 225 Roman-i
;; (x #o226 ...) ; 226 Roman-ii
;; (x #o227 ...) ; 227 Roman-iii
;; (x #o230 ...) ; 230 Roman-iv
;; (x #o231 ...) ; 231 Hand-up
;; (x #o232 ...) ; 232 Hand-down
;; (x #o233 ...) ; 233 Hand-left
;; (x #o234 ...) ; 234 Hand-right
;; (x #o235 ...) ; 235 System
;; (x #o236 ...) ; 236 Network
;; 237-377 reserved for the future
))
"Symbol prettification for viewing Lisp Machine files.")
(defun lispm-unibus-to-virtual (addr) (+ (/ addr 2) #o77400000))
(defun lispm-virtual-to-unibus (addr) (* (- addr #o77400000) 2))
(defun lispm-delete-header-nulls ()
(interactive)
(goto-char (point-min))
(delete-horizontal-space)
(while (char-equal (char-after) ?\C-@)
(delete-forward-char 1)))
(defun lispm-delete-trailing-nulls ()
(interactive)
(goto-char (point-max))
(while (char-equal (char-before) ?\C-@)
(delete-backward-char 1)))
;;;---!!! LISPM-DATE: Doesn't take into account daylight savings (EDT
;;;---!!! and EST). DST-ADJUST-TIME should be able to do the trick.
(defun lispm-date (epoch)
(format-time-string "%m/%d/%y %H:%M:%S" (seconds-to-time (- epoch 2208988800)) "EST"))
(defun lispm-delete-tape-marks ()
(interactive)
(flet ((hdr (s) (concat (string ?\C-@) " " s " " (string ?\C-@))))
(dolist (x (list
(hdr "BKHD") ; BLOCK HEAD
(hdr "BKTL") ; BLOCK TAIL
(hdr "BKFM") ; FILE MARK
(hdr "BKER") ; BLOCK ERROR
(hdr "BKET") ; END OF TAPE
(hdr "BKLI") ; BLOCK LENGTH INCONSISTENCY
))
(replace-string x "" nil (point-min) (point-max)))))
(defconst lispm-mode--prettify-symbols-alist lispm-prettify-symbols-alist)
(defvar lispm-mode--old-prettify-symbols-alist prettify-symbols-alist)
(defun lispm-mode--enable ()
(prettify-symbols-mode -1)
(setq-local lispm-mode--old-prettify-symbols-alist prettify-symbols-alist)
(setq-local prettify-symbols-alist (append lispm-mode--prettify-symbols-alist prettify-symbols-alist))
(setq-local prettify-symbols-compose-predicate (lambda (begin end match) t))
(prettify-symbols-mode 1))
(defun lispm-mode--disable ()
(prettify-symbols-mode -1)
(setq-local prettify-symbols-alist lispm-mode--old-prettify-symbols-alist)
(prettify-symbols-mode 1))
(define-minor-mode lispm-mode
"Minor mode for handling Lisp Machine files."
:global nil
(if lispm-mode
(lispm-mode--enable)
(lispm-mode--disable)))
(provide 'lispm)
;;; lispm ends here.