web68.el

Birothilu

Dec 21st, 2014

759

Never

Add comment

Not a member of Pastebin yet? Sign Up, it unlocks many cool features!

Lisp 16.48 KB | None | 0 0

raw download clone embed print report

;;;; -*- Mode: Lisp; lexical-binding: t; -*-
;;;; web68.el --- major mode for editing Web 68 source
;;;; This file contains Web 68 mode.
;;;; It is used to colourise Web 68 and Algol 68 files.
;;;; Author: Sian Mountbatten <[email protected]>
;;;; Keywords: languages
(defgroup web68 nil
"Major mode for editing Web 68/Algol 68 source in Emacs."
:link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
:group 'languages)
(defvar web68-mode-abbrev-table nil
"Abbrev table in use in Web68 mode buffers.")
(define-abbrev-table 'web68-mode-abbrev-table ())
(defvar web68-mode-map
(let ((map (make-sparse-keymap)))
map)
"Keymap used in Web68 mode.")
(defvar web68-imenu-generic-expression
'((nil "^[ \t]*\$PROC\\|OP\$[ \t\n]+\$[a-zA-Z0-9_.:]+\$" 2))
"Imenu expression for Web68 mode. See `imenu-generic-expression'.")
(defvar web68-mode-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?\( "()" st)
(modify-syntax-entry ?\) ")(" st)
(modify-syntax-entry ?# "$" st)
(modify-syntax-entry ?{ "<" st)
(modify-syntax-entry ?} ">" st)
(modify-syntax-entry ?$ "$" st)
(modify-syntax-entry ?_ "_" st)
st)
"Syntax table in use in Web68-mode buffers.")
;;; Define the font lock colours
(defface *web68-grey*
'((((class color) (min-colors 88) (background dark))
;.
:background "black" :foreground "#808080"))
"Used for Web 68 text."
:group 'web68)
(defface *web68-red*
'((((class color) (min-colors 88) (background dark))
;.
:background "black" :foreground "red"))
"Used for numbers."
:group 'web68)
(defface *web68-darkcyan*
'((((class color) (min-colors 88) (background dark))
;.
:background "black" :foreground "darkCyan"))
"Used for punctuation."
:group 'web68)
(defface *web68-yellow*
'((((class color) (min-colors 88) (background dark))
;.
:background "black" :foreground "yellow"))
"Used for strings."
:group 'web68)
(defface *web68-brown*
'((((class color) (min-colors 88) (background dark))
;.
:background "black" :foreground "brown"))
"Used for comments."
:group 'web68)
(defface *web68-magenta*
'((((class color) (min-colors 88) (background dark))
;.
:background "black" :foreground "magenta"))
"Used for operators."
:group 'web68)
(defface *web68-green*
'((((class color) (min-colors 88) (background dark))
;.
:background "black" :foreground "green"))
"Used for dates/delimited text."
:group 'web68)
(defface *web68-cyan*
'((((class color) (min-colors 88) (background dark))
;.
:background "black" :foreground "cyan"))
"Used for Algol 68 modes and Web 68 commands."
:group 'web68)
(defface *web68-blue*
'((((class color) (min-colors 88) (background dark))
;.
:background "black" :foreground "skyblue"))
"Used for identifiers."
:group 'web68)
(defface *web68-white*
'((((class color) (min-colors 88) (background dark))
;.
:background "black" :foreground "white"))
"Used for bold tags."
:group 'web68)
;;;; The next data structure is used to identify a bold tag.
;;;; The length of the tag determines which sorted list is used.
;;;; The `chop' function then finds the actual position of the
;;;; bold tag and, consequently, its face property.
;;;;
;;;; Define which face is used for each bold tag
(defconst *web68-bold-tags*
'(nil
(("I" *web68-magenta*)) ; length 1
(("AT" *web68-white*) ; length 2
("BY" *web68-white*)
("CO" *web68-white*)
("DO" *web68-white*)
("EQ" *web68-magenta*)
("FI" *web68-white*)
("GE" *web68-magenta*)
("GT" *web68-magenta*)
("IF" *web68-white*)
("IM" *web68-magenta*)
("IN" *web68-white*)
("IS" *web68-white*)
("LE" *web68-magenta*)
("LT" *web68-magenta*)
("NE" *web68-magenta*)
("OD" *web68-white*)
("OF" *web68-white*)
("OP" *web68-white*)
("OR" *web68-magenta*)
("RE" *web68-magenta*)
("TO" *web68-white*)
("UP" *web68-magenta*))
(("ABS" *web68-magenta*) ; length 3
("AND" *web68-magenta*)
("BIN" *web68-magenta*)
("DIV" *web68-magenta*)
("END" *web68-white*)
("FOR" *web68-white*)
("INT" *web68-cyan*)
("LOC" *web68-cyan*)
("LWB" *web68-magenta*)
("MOD" *web68-magenta*)
("NIL" *web68-red*)
("NOT" *web68-magenta*)
("OUT" *web68-white*)
("REF" *web68-cyan*)
("SHL" *web68-magenta*)
("SHR" *web68-magenta*)
("UPB" *web68-magenta*)
("USE" *web68-white*))
(("BITS" *web68-cyan*) ; length 4
("BOOL" *web68-cyan*)
("CASE" *web68-white*)
("CHAR" *web68-cyan*)
("CONJ" *web68-magenta*)
("DECS" *web68-white*)
("DOWN" *web68-magenta*)
("ELEM" *web68-magenta*)
("ELIF" *web68-white*)
("ELSE" *web68-white*)
("ESAC" *web68-white*)
("EXIT" *web68-white*)
("FILE" *web68-cyan*)
("FLEX" *web68-cyan*)
("FROM" *web68-white*)
("GOTO" *web68-white*)
("HEAP" *web68-cyan*)
("ISNT" *web68-white*)
("KEEP" *web68-white*)
("LONG" *web68-cyan*)
("MODE" *web68-white*)
("OUSE" *web68-white*)
("OVER" *web68-magenta*)
("PRIO" *web68-white*)
("PROC" *web68-cyan*)
("REAL" *web68-cyan*)
("REPR" *web68-magenta*)
("SKIP" *web68-white*)
("THEN" *web68-white*)
("TRUE" *web68-red*)
("VOID" *web68-cyan*))
(("BEGIN" *web68-white*) ; length 5
("COMPL" *web68-cyan*)
("DIVAB" *web68-magenta*)
("EMPTY" *web68-red*)
("FALSE" *web68-red*)
("MODAB" *web68-magenta*)
("SHORT" *web68-cyan*)
("UNION" *web68-cyan*)
("WHILE" *web68-white*))
(("ENTIER" *web68-magenta*) ; length 6
("FINISH" *web68-white*)
("OVERAB" *web68-magenta*)
("PLUSAB" *web68-magenta*)
("PLUSTO" *web68-magenta*)
("STRING" *web68-cyan*)
("STRUCT" *web68-cyan*))
(("CHANNEL" *web68-cyan*) ; length 7
("CONTEXT" *web68-white*)
("MINUSAB" *web68-magenta*)
("PROGRAM" *web68-white*)
("TIMESAB" *web68-magenta*))))
(setq *web68-font-lock-keywords*
(let ((ops "\\<\$A\\(?:BS\\|ND\$\\|BIN\\|CONJ\\|D\$?:IV\\(?:AB\$?\\|OWN\\)\\|E\$?:LEM\\|NTIER\\|Q\$\\|G[ET]\\|IM?\\|L\$?:WB\\|[ET]\$\\|M\$?:INUSAB\\|OD\\(?:AB\$?\\)\\|N\$?:E\\|OT\$\\|O\$?:R\\|VER\\(?:AB\$?\\)\\|PLUS\$?:AB\\|TO\$\\|RE\$?:PR\$?\\|SH[LR]\\|TIMESAB\\|UPB?\\)\\>")
(bold-tags "\\<\$AT\\|B\\(?:EGIN\\|Y\$\\|C\$?:ASE\\|ONTEXT\$\\|D\$?:ECS\\|O\$\\|E\$?:L\\(?:IF\\|SE\$\\|ND\\|SAC\\|XIT\\)\\|F\$?:I\\(?:NISH\$?\\|OR\\|ROM\\)\\|GOTO\\|I\$?:SNT\\|[FNS]\$\\|KEEP\\|MODE\\|O\$?:U\\(?:SE\\|T\$\\|[DFP]\\)\\|PR\$?:IO\\|OGRAM\$\\|SKIP\\|T\$?:HEN\\|O\$\\|\$?:US\\|WHIL\$E\\)\\>")
(modes "\\<\$B\\(?:ITS\\|OOL\$\\|C\$?:HA\\(?:NNEL\\|R\$\\|OMPL\\)\\|F\$?:ILE\\|LEX\$\\|HEAP\\|INT\\|LO\$?:C\\|NG\$\\|PROC\\|RE\$?:AL\\|F\$\\|S\$?:HORT\\|TR\\(?:ING\\|UCT\$\\)\\|UNION\\|VOID\\)\\>")
(number-tags "\\<\$EMPTY\\|FALSE\\|NIL\\|TRUE\$\\>"))
'((list (ops . *web68-magenta*))
(list (bold-tags . *web68-white*))
(list (modes . *web68-cyan*))
(list (number-tags . *web68-red*)))))
; Keywords for Web 68 mode. Font-locking is performed by `web68-finite-state-machine'."
(defun web68-chop
(object sequence &optional key comp order)
"Finds OBJECT in a sorted SEQUENCE.
KEY -- function to extract the key from an element of
SEQUENCE (default #'identity).
COMP -- function to compare OBJECTs (default #'string=).
ORDER -- function to order OBJECTs (default #'string<).
CHOP returns a list containing two values:
if (cadr return) = nil, OBJECT is not in SEQUENCE
else (car return) gives its index in SEQUENCE."
(let ((fkey (if key key 'identity))
(fcomp (if comp comp 'string=))
(forder (if order order 'string<))
(l 0)
(u (1- (length sequence)))
m item)
(while
(if (<= l u)
(progn
(setf m (/ (+ l u) 2))
(setf item (elt sequence m))
(not (funcall fcomp object (funcall fkey item))))
nil)
(if (funcall forder object (funcall fkey item))
(setf u (1- m))
(setf l (1+ m))))
(list (if (> l u) u m)
(if (> l u) nil m))))
(defvar *web68-tag* nil) ; set to tag by web68-finite-state-machine
(defun web68-set-text-colour (leng face)
"Set the colour of the chars at (POINT):(POINT+leng) to FACE."
(put-text-property (point) (+ (point) leng) 'face face))
(defun web68-find-bold-tag ()
"Identify the tag in *web68-tag* and colourise it accordingly.
If the tag is not identified, colourise it as a mode indicant."
(let* ((lst (nth (length *web68-tag*) *web68-bold-tags*))
(ret (web68-chop *web68-tag* lst)))
(if (cadr ret)
(web68-set-text-colour (length *web68-tag*)
(cadr (nth (car ret) lst)))
(web68-set-text-colour (length *web68-tag*) *web68-cyan*))))
(defvar *states*
'(;; ('face
;; (flags/nil matcher face/nil 'function/next-state))
(*web68-darkcyan* ; default: punctuation [0] Algol 68
(nil "COMMENT" *web68-white* 1) ; start of COMMENT comment
(nil "#" *web68-white* 3) ; start of # comment
(nil "{" *web68-white* 4) ; start of brace comment
(nil "!" *web68-darkcyan* 9) ; end of snippet
(?- "@[ 123adhim<^.!=\/,]" nil 9) ; Web 68 command
(nil "@@" *web68-magenta* 0) ; AT operator
(?- "[A-Z]" nil 5) ; start of a bold tag
(?- "[a-z]" nil 6) ; start of an identifier
(?- "[0-9]" nil 7) ; start of a number
(?- "[.]" nil 7) ; start of a REAL
(?- "[-<=>+*/%^]" nil 8) ; start of an operator
(nil ":=:" *web68-magenta* 0)
(nil ":/=:" *web68-magenta* 0)
(nil ":=" *web68-darkcyan* 0))
(*web68-brown* ; default: comment [1] COMMENT state
(nil "COMMENT" *web68-white* 0))
(*web68-brown* ; default: comment [2] CO state
(nil "CO[^A-Z]" '*web68-white* 0))
(*web68-brown* ; default: comment [3] # state
(nil "#" *web68-white* 0)) ; end of # comment
(*web68-brown* ; default: comment [4] { state
(nil "}" *web68-white* 0))
(*web68-white* ; default: bold tag [5]
(?f "[A-Z][0-9A-Z]*" nil 'web68-find-bold-tag))
(*web68-blue* ; default: identifier [6]
(nil "[a-z][0-9a-z ]" *web68-blue* 0))
(*web68-red* ; default: number [7]
(nil "2r[01 ]+" *web68-red* 0) ; binary denotation
(nil "4r[0-3 ]+" *web68-red* 0) ; base-4 "
(nil "8r[0-7 ]+" *web68-red* 0) ; octal "
(nil "16r[0-9a-f ]+" *web68-red* 0) ; hex "
;; reals with exponent: -1e+10 .1e+10 +1.2e+10
(nil "[-+]?[0-9 ]+e[-+]?[0-9]+" *web68-red* 0)
(nil "[-+]?\.[0-9 ]+e[-+]?[0-9]+" *web68-red* 0)
(nil "[-+]?[0-9 ]+\.[0-9 ]+e[-+]?[0-9]+" *web68-red* 0)
;; reals without exponent: -1 .1 +1.2
(nil "[-+]?[0-9 ]+" *web68-red* 0)
(nil "[-+]?\.[0-9 ]+" *web68-red* 0)
(nil "[-+]?[0-9 ]+\.[0-9 ]+" *web68-red* 0))
(*web68-magenta* ; default: operator [8]
(nil "[-+*/%]:=" *web68-magenta* 0)
(nil "\$%*:=\\|+=:\\|\*\*\\|/=\$" *web68-magenta* 0)
(nil "\$<=\\|>=\$" *web68-magenta* 0)
(nil "[-+*/%^<>=]" *web68-magenta* 0)) ; simple operator
(*web68-grey* ; default: Web 68 text [9]
(nil "!" *web68-white* 0) ; start of snippet
(nil "<" *web68-magenta* 11) ; start of HTML tag
(nil "@[123 ]" *web68-cyan* 9) ; section command
(nil "@[adm]" *web68-cyan* 0) ; to Algol 68 state
(nil "@h" *web68-cyan* 12) ; HTML state
(nil "@[i<.^]" *web68-cyan* 10) ; start of delimited text
(nil "@[!\/,=]" '*web68-cyan* 0))
(*web68-green* ; default: delimited text [10]
(nil "@>=?" *web68-cyan* 0)) ; end of delimited text
(*web68-magenta* ; default: HTML tag [11]
(nil ">" *web68-magenta* 9)) ; end of HTML tag
(*web68-grey* ; default: HTML state [12]
(nil "@>" *web68-cyan* 9)))) ; end of HTML state
(defmacro inc (var)
(list 'setq var (list '1+ var)))
(defun web68-finite-state-machine (start end &optional verbose)
"Executes the transitions defined in STATES starting at START
upto END. The elements of each transition have the following meanings:
Element 0: flags:
nil -- no flags
- -- (point) should not be moved after the match
f -- the 3rd element is a function instead of a face
Element 1:
matcher
Element 2:
face/function
Element 3:
next state."
(let ((current-state-index 0)
state
default
index
transition
flags
regexp
transition-setup)
(fset 'transition-setup
(lambda (inx stat)
(setq transition (nth inx stat)
flags (car transition)
regexp (cadr transition))))
(goto-char start)
(while (< (point) end)
(setq state (nth current-state-index *states*)
default (car state)
index 1)
(while (< index (length state))
((symbol-function 'transition-setup) index state)
;; we need a function which computes transition, flags and regexp each
;; time index is incremented
(while (not (looking-at regexp))
((symbol-function 'transition-setup) (inc index) state))
(if (= index (length state))
;; no match
(progn
(web68-set-text-colour 1 default-face)
(forward-char 1))
;; match
(let ((matched (match-string 0)))
(cond ((zerop (length flags)) ; no flags
(web68-set-text-colour (length matched)
(nth 2 transition))
(forward-char (length matched)))
((char-equal ?f flags) ; Element 2 is a function
(setq *web68-tag*
(buffer-substring-no-properties
(point) (+ (point) (length matched))))
(funcall (nth 2 transition)) ; call the function
(forward-char (length matched)))
((char-equal ?- flags) ; Don't move point
(web68-set-text-colour (length matched)
(nth 2 transition))))
(setq current-state-index (nth 3 transition))))))))
(defun web68-find-font-lock-region ()
"Finds the region over which font-locking will occur.
(1) Looks backward for a Web 68 sectioning command or the buffer beginning.
(2) Looks forward for a Web 68 sectioning command or the buffer end.
Due account is taken of the visible part of the text."
(goto-char (window-start))
(if (re-search-backward "@[123 ]" (point-min) t)
(push-mark (point))
(push-mark (point-min)))
(goto-char (window-end))
(if (re-search-forward "@[123 ]" (point-max) t)
(beginning-of-line)
(goto-char (point-max))))
(defun web68-find-font-lock-buffer ()
"Sets POINT and MARK to POINT-MIN and POINT-MAX respectively."
(push-mark (point-max))
(goto-char (point-min)))
;;;###autoload
(define-derived-mode
web68-mode prog-mode "Web 68"
"Major mode for editing Web 68 code as well as displaying Algol 68 code."
(setq-local case-fold-search nil)
(setq-local blink-matching-paren-dont-ignore-comments t)
;; Font lock support
(setq-local font-lock-defaults
(list
*web68-font-lock-keywords* t nil nil nil
'(font-lock-fontify-region-function . web68-finite-state-machine)
'(font-lock-fontify-buffer-function . web68-find-font-lock-buffer)))
(add-hook 'web68-mode-hook 'web68-find-font-lock-region))
(provide 'web68)
;;;; web68.el ends here