Skip to content
Snippets Groups Projects
Commit dd4e4f02 authored by wlott's avatar wlott
Browse files

Ripped bit/font noise out of #\ processing.

parent a45fcf94
No related branches found
No related tags found
No related merge requests found
...@@ -20,53 +20,21 @@ ...@@ -20,53 +20,21 @@
(proclaim '(special *read-suppress* std-lisp-readtable *bq-vector-flag*)) (proclaim '(special *read-suppress* std-lisp-readtable *bq-vector-flag*))
(defun sharp-backslash (stream backslash font)
(defun sharp-backslash (stream backslash ignore)
(declare (ignore ignore))
(unread-char backslash stream) (unread-char backslash stream)
(let* ((*readtable* std-lisp-readtable) (let* ((*readtable* std-lisp-readtable)
(bitnames ())
(charstring (read-extended-token stream))) (charstring (read-extended-token stream)))
(declare (simple-string charstring)) (declare (simple-string charstring))
(when *read-suppress* (return-from sharp-backslash nil)) (cond (*read-suppress* nil)
;;find bit name prefixes ((= (the fixnum (length charstring)) 1)
(do ((i (position #\- charstring) (position #\- charstring))) (char charstring 0))
((or (null i) (zerop (the fixnum i)))) ((name-char charstring))
(let ((bitname (string-upcase (subseq charstring 0 i)))) (t
(setq charstring (subseq charstring (1+ (the fixnum i)))) (error "Meaningless character name: ~S" charstring)))))
;;* symbols in alist are a kludge to circumvent xc bogosity.
(let ((expansion (cdr (assoc bitname '(("C" . CONTROL)
("M" . META)
("H" . HYPER)
("S" . SUPER))
:test #'equal))))
(if expansion (setq bitname (symbol-name expansion)))
(cond ((member bitname '("CONTROL" "META" "HYPER" "SUPER")
:test #'EQUAL)
(if (not (member bitname bitnames :test #'EQUAL))
(push bitname bitnames)
(error
"Redundant bit name in character name: ~A"
bitname)))
(t (error
"Meaningless bit name in character name: ~A"
bitname))))))
;;build un-hyphenated char, add specified bits:
(let ((char (if (= (the fixnum (length charstring)) 1)
(char charstring 0)
(name-char charstring))))
(cond (char
(if font
(setq char (make-char char 0 font)))
(if (member "CONTROL" bitnames :test #'EQUAL)
(setq char (set-char-bit char :control t)))
(if (member "META" bitnames :test #'EQUAL)
(setq char (set-char-bit char :meta t)))
(if (member "HYPER" bitnames :test #'EQUAL)
(setq char (set-char-bit char :hyper t)))
(if (member "SUPER" bitnames :test #'EQUAL)
(setq char (set-char-bit char :super t)))
char)
(t (error "Meaningless character name ~A"
charstring))))))
(defun sharp-quote (stream ignore1 ignore2) (defun sharp-quote (stream ignore1 ignore2)
(declare (ignore ignore1 ignore2)) (declare (ignore ignore1 ignore2))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment