;;; 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.
