Permalink
Browse files

Initial import of colorize.

git-svn-id: svn://unmutual.info/colorize@84 3cf5c468-6606-0410-8af3-f24f8ca847a0
  • Loading branch information...
0 parents commit d47148395385a7a0260c444efe3f52f427233fae chandler committed Dec 19, 2005
Showing with 3,340 additions and 0 deletions.
  1. +128 −0 Mop_Sym.txt
  2. +30 −0 abbrev.lisp
  3. +221 −0 clhs-lookup.lisp
  4. +39 −0 coloring-css.lisp
  5. +406 −0 coloring-types.lisp
  6. +8 −0 colorize-package.lisp
  7. +25 −0 colorize.asd
  8. +332 −0 colorize.lisp
  9. +31 −0 elisp-lookup.lisp
  10. +1,912 −0 elisp-symbols.lisp-expr
  11. +31 −0 r5rs-lookup.lisp
  12. +177 −0 r5rs-symbols.lisp-expr
@@ -0,0 +1,128 @@
+SPEC2
+dictionary.html#spec2
+ADD-DEPENDENT
+dictionary.html#add-dependent
+ADD-DIRECT-METHOD
+dictionary.html#add-direct-method
+ADD-DIRECT-SUBCLASS
+dictionary.html#add-direct-subclass
+ADD-METHOD
+dictionary.html#add-method
+ALLOCATE-INSTANCE
+dictionary.html#allocate-instance
+CLASS-
+dictionary.html#class-
+COMPUTE-APPLICABLE-METHODS
+dictionary.html#compute-applicable-methods
+COMPUTE-APPLICABLE-METHODS-USING-CLASSES
+dictionary.html#compute-applicable-methods-using-classes
+COMPUTE-CLASS-PRECEDENCE-LIST
+dictionary.html#compute-class-precedence-list
+COMPUTE-DEFAULT-INITARGS
+dictionary.html#compute-default-initargs
+COMPUTE-DISCRIMINATING-FUNCTION
+dictionary.html#compute-discriminating-function
+COMPUTE-EFFECTIVE-METHOD
+dictionary.html#compute-effective-method
+COMPUTE-EFFECTIVE-SLOT-DEFINITION
+dictionary.html#compute-effective-slot-definition
+COMPUTE-SLOTS
+dictionary.html#compute-slots
+DIRECT-SLOT-DEFINITION-CLASS
+dictionary.html#direct-slot-definition-class
+EFFECTIVE-SLOT-DEFINITION-CLASS
+dictionary.html#effective-slot-definition-class
+ENSURE-CLASS
+dictionary.html#ensure-class
+ENSURE-CLASS-USING-CLASS
+dictionary.html#ensure-class-using-class
+ENSURE-GENERIC-FUNCTION
+dictionary.html#ensure-generic-function
+ENSURE-GENERIC-FUNCTION-USING-CLASS
+dictionary.html#ensure-generic-function-using-class
+EQL-SPECIALIZER-OBJECT
+dictionary.html#eql-specializer-object
+EXTRACT-LAMBDA-LIST
+dictionary.html#extract-lambda-list
+EXTRACT-SPECIALIZER-NAMES
+dictionary.html#extract-specializer-names
+FINALIZE-INHERITANCE
+dictionary.html#finalize-inheritance
+FIND-METHOD-COMBINATION
+dictionary.html#find-method-combination
+FUNCALLABLE-STANDARD-INSTANCE-ACCESS
+dictionary.html#funcallable-standard-instance-access
+GENERIC-FUNCTION-
+dictionary.html#generic-function-
+</A>
+dictionary.html#</a>
+CLASS-MO-INITARGS
+dictionary.html#class-mo-initargs
+</A>
+dictionary.html#</a>
+GF-MO-INITARGS
+dictionary.html#gf-mo-initargs
+INITIALIZATION
+dictionary.html#Initialization
+METHOD-MO-INITARGS
+dictionary.html#method-mo-initargs
+INITIALIZATION
+dictionary.html#Initialization
+SLOTD-MO-INITARGS
+dictionary.html#slotd-mo-initargs
+INTERN-EQL-SPECIALIZER
+dictionary.html#intern-eql-specializer
+MAKE-INSTANCE
+dictionary.html#make-instance
+MAKE-METHOD-LAMBDA
+dictionary.html#make-method-lambda
+MAP-DEPENDENTS
+dictionary.html#map-dependents
+METHOD-
+dictionary.html#method-
+CLASS-MO-READERS
+dictionary.html#class-mo-readers
+GF-MO-READERS
+dictionary.html#gf-mo-readers
+METHOD-MO-READERS
+dictionary.html#method-mo-readers
+SLOTD-MO-READERS
+dictionary.html#slotd-mo-readers
+READER-METHOD-CLASS
+dictionary.html#reader-method-class
+REMOVE-DEPENDENT
+dictionary.html#remove-dependent
+REMOVE-DIRECT-METHOD
+dictionary.html#remove-direct-method
+REMOVE-DIRECT-SUBCLASS
+dictionary.html#remove-direct-subclass
+REMOVE-METHOD
+dictionary.html#remove-method
+SET-FUNCALLABLE-INSTANCE-FUNCTION
+dictionary.html#set-funcallable-instance-function
+(SETF CLASS-NAME)
+dictionary.html#(setf class-name)
+(SETF GENERIC-FUNCTION-NAME)
+dictionary.html#(setf generic-function-name)
+(SETF SLOT-VALUE-USING-CLASS)
+dictionary.html#(setf slot-value-using-class)
+SLOT-BOUNDP-USING-CLASS
+dictionary.html#slot-boundp-using-class
+SLOT-DEFINITION-
+dictionary.html#slot-definition-
+SLOT-MAKUNBOUND-USING-CLASS
+dictionary.html#slot-makunbound-using-class
+SLOT-VALUE-USING-CLASS
+dictionary.html#slot-value-using-class
+SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
+dictionary.html#specializer-direct-generic-functions
+SPECIALIZER-DIRECT-METHODS
+dictionary.html#specializer-direct-methods
+STANDARD-INSTANCE-ACCESS
+dictionary.html#standard-instance-access
+UPDATE-DEPENDENT
+dictionary.html#update-dependent
+VALIDATE-SUPERCLASS
+dictionary.html#validate-superclass
+WRITER-METHOD-CLASS
+dictionary.html#writer-method-class
@@ -0,0 +1,30 @@
+(defpackage :abbrev (:use :cl :split-sequence)
+ (:export :abbrev))
+(in-package :abbrev)
+
+(defun could-be-wrap (term char-set)
+ (loop for char in char-set
+ if (and (> (length term) 1)
+ (char= (elt term 0) char)
+ (char= (elt term (1- (length term))) char))
+ return char))
+
+(defun abbrev (term &key wrap)
+ (if (> (length term) 0)
+ (if (char= (elt term 0) #\:)
+ (abbrev (subseq term 1))
+ (let ((char (could-be-wrap term '(#\* #\+))))
+ (if char
+ (abbrev (subseq term 1 (1- (length term))) :wrap char)
+ (let ((split (split-sequence #\- term)))
+ (if (and (> (length split) 1)
+ (every #'(lambda (e) (> (length e) 0)) split))
+ (let ((abbrev (format nil "~{~C~^-~}"
+ (mapcar #'(lambda (e)
+ (elt e 0)) split))))
+ (when wrap
+ (setf abbrev (format nil "~C~A~C"
+ wrap abbrev wrap))
+ (setf term (format nil "~C~A~C"
+ wrap term wrap)))
+ abbrev))))))))
@@ -0,0 +1,221 @@
+(defpackage :clhs-lookup (:use :common-lisp) (:export :symbol-lookup
+ :populate-table
+ :spec-lookup))
+(in-package :clhs-lookup)
+
+(defparameter *hyperspec-pathname*
+ (merge-pathnames
+ (make-pathname :directory '(:relative "HyperSpec"))
+ (user-homedir-pathname)))
+
+(defparameter *hyperspec-map-file*
+ (merge-pathnames "Data/Map_Sym.txt" *hyperspec-pathname*))
+
+(defparameter *hyperspec-root* "http://www.lispworks.com/reference/HyperSpec/")
+
+;;; AMOP.
+(defparameter *mop-map-file*
+ (merge-pathnames "Mop_Sym.txt" #.*compile-file-pathname*))
+
+(defparameter *mop-root* "http://www.alu.org/mop/")
+
+(defvar *symbol-table* (make-hash-table :test 'equalp))
+
+(defvar *abbrev-table* (make-hash-table :test 'equalp))
+
+(defvar *section-table* (make-hash-table :test 'equalp))
+
+(defvar *format-table* (make-hash-table :test 'equalp))
+
+(defvar *read-macro-table* (make-hash-table :test 'equalp))
+
+(defvar *populated-p* nil)
+
+(defun add-clhs-section-to-table (&rest numbers)
+ (let ((key (format nil "~{~d~^.~}" numbers))
+ (target (concatenate 'string *hyperspec-root* (format nil "Body/~2,'0d_~(~{~36r~}~).htm" (car numbers) (mapcar #'(lambda (x) (+ x 9)) (cdr numbers))))))
+ (setf (gethash key *section-table*) target)))
+
+(defun valid-target (&rest numbers)
+ (probe-file (format nil "Body/~2,'0d_~(~{~36r~}~).htm" (car numbers) (mapcar #'(lambda (x) (+ x 9)) (cdr numbers)))))
+
+(defvar *last-warn-time* 0)
+
+(defun populate-table ()
+ (unless *populated-p*
+ ;; Hyperspec
+ (with-open-file (s *hyperspec-map-file* :if-does-not-exist nil)
+ ;; populate the table with the symbols from the Map file
+ ;; this bit is easy and portable.
+ (unless s
+ (when (> (- (get-universal-time) *last-warn-time*) 10)
+ (format *trace-output* "Warning: could not find hyperspec map file. Adjust the path at the top of clhs-lookup.lisp to get links to the HyperSpec.~%")
+ (setf *last-warn-time* (get-universal-time)))
+ (return-from populate-table nil))
+ (flet ((set-symbol (sym url)
+ (setf (gethash sym *symbol-table*) url)
+ (let ((abbrev (abbrev:abbrev sym)))
+ (and abbrev
+ (pushnew sym (gethash abbrev *abbrev-table* nil)
+ :test #'string-equal)))))
+ (do ((symbol-name (read-line s nil s) (read-line s nil s))
+ (url (read-line s nil s) (read-line s nil s)))
+ ((eq url s) 'done)
+ (set-symbol symbol-name (concatenate 'string *hyperspec-root* (subseq url 3)))))
+ ;; add in section references.
+ (let ((*default-pathname-defaults* *hyperspec-pathname*))
+ ;; Yuk. I know. Fixes welcome.
+ (loop for section from 0 to 27
+ do (add-clhs-section-to-table section)
+ do (loop named s for s1 from 1 to 26
+ unless (valid-target section s1)
+ do (return-from s nil)
+ do (add-clhs-section-to-table section s1)
+ do (loop named ss for s2 from 1 to 26
+ unless (valid-target section s1 s2)
+ do (return-from ss nil)
+ do (add-clhs-section-to-table section s1 s2)
+ do (loop named sss for s3 from 1 to 26
+ unless (valid-target section s1 s2 s3)
+ do (return-from sss nil)
+ do (add-clhs-section-to-table section s1 s2 s3)
+ do (loop named ssss for s4 from 1 to 26
+ unless (valid-target section s1 s2 s3 s4)
+ do (return-from ssss nil)
+ do (add-clhs-section-to-table section s1 s2 s3 s4)
+ do (loop named sssss for s5 from 1 to 26
+ unless (valid-target section s1 s2 s3 s4 s5)
+ do (return-from sssss nil)
+ do (add-clhs-section-to-table section s1 s2 s3 s4 s5))))))))
+ ;; format directives
+ (loop for code from 32 to 127
+ do (setf (gethash (format nil "~~~A" (code-char code)) *format-table*)
+ (concatenate 'string
+ *hyperspec-root*
+ (case (code-char code)
+ ((#\c #\C) "Body/22_caa.htm")
+ ((#\%) "Body/22_cab.htm")
+ ((#\&) "Body/22_cac.htm")
+ ((#\|) "Body/22_cad.htm")
+ ((#\~) "Body/22_cae.htm")
+ ((#\r #\R) "Body/22_cba.htm")
+ ((#\d #\D) "Body/22_cbb.htm")
+ ((#\b #\B) "Body/22_cbc.htm")
+ ((#\o #\O) "Body/22_cbd.htm")
+ ((#\x #\X) "Body/22_cbe.htm")
+ ((#\f #\F) "Body/22_cca.htm")
+ ((#\e #\E) "Body/22_ccb.htm")
+ ((#\g #\G) "Body/22_ccc.htm")
+ ((#\$) "Body/22_ccd.htm")
+ ((#\a #\A) "Body/22_cda.htm")
+ ((#\s #\S) "Body/22_cdb.htm")
+ ((#\w #\W) "Body/22_cdc.htm")
+ ((#\_) "Body/22_cea.htm")
+ ((#\<) "Body/22_ceb.htm")
+ ((#\i #\I) "Body/22_cec.htm")
+ ((#\/) "Body/22_ced.htm")
+ ((#\t #\T) "Body/22_cfa.htm")
+ ;; FIXME
+ ((#\<) "Body/22_cfb.htm")
+ ((#\>) "Body/22_cfc.htm")
+ ((#\*) "Body/22_cga.htm")
+ ((#\[) "Body/22_cgb.htm")
+ ((#\]) "Body/22_cgc.htm")
+ ((#\{) "Body/22_cgd.htm")
+ ((#\}) "Body/22_cge.htm")
+ ((#\?) "Body/22_cgf.htm")
+ ((#\() "Body/22_cha.htm")
+ ((#\)) "Body/22_chb.htm")
+ ((#\p #\P) "Body/22_chc.htm")
+ ((#\;) "Body/22_cia.htm")
+ ((#\^) "Body/22_cib.htm")
+ ((#\Newline) "Body/22_cic.htm")
+ (t "Body/22_c.htm")))))
+ ;; read macros
+ (loop for (char page) in '((#\( "a")
+ (#\) "b")
+ (#\' "c")
+ (#\; "d")
+ (#\" "e")
+ (#\` "f")
+ (#\, "g")
+ (#\# "h"))
+ do (setf (gethash (format nil "~A" char) *read-macro-table*)
+ (concatenate 'string
+ *hyperspec-root*
+ "Body/02_d"
+ page
+ ".htm")))
+ (loop for code from 32 to 127
+ do (setf (gethash (format nil "#~A" (code-char code)) *read-macro-table*)
+ (concatenate 'string
+ *hyperspec-root*
+ "Body/02_dh"
+ (case (code-char code)
+ ((#\\) "a")
+ ((#\') "b")
+ ((#\() "c")
+ ((#\*) "d")
+ ((#\:) "e")
+ ((#\.) "f")
+ ((#\b #\B) "g")
+ ((#\o #\O) "h")
+ ((#\x #\X) "i")
+ ((#\r #\R) "j")
+ ((#\c #\C) "k")
+ ((#\a #\A) "l")
+ ((#\s #\S) "m")
+ ((#\p #\P) "n")
+ ((#\=) "o")
+ ((#\#) "p")
+ ((#\+) "q")
+ ((#\-) "r")
+ ((#\|) "s")
+ ((#\<) "t")
+ ((#\)) "v")
+ (t ""))
+ ".htm")))
+ ;; glossary.
+ )
+ ;; MOP
+ (with-open-file (s *mop-map-file*)
+ (do ((symbol-name (read-line s nil s) (read-line s nil s))
+ (url (read-line s nil s) (read-line s nil s)))
+ ((eq url s) 'done)
+ (setf (gethash (concatenate 'string "MOP:" symbol-name) *symbol-table*) (concatenate 'string *mop-root* url))))
+ (setf *populated-p* t)))
+
+(defun abbrev-lookup (term)
+ (let ((abbrevs (gethash term *abbrev-table* nil)))
+ (if (eql (length abbrevs) 0)
+ nil
+ (if (eql (length abbrevs) 1)
+ (format nil "~A: ~A"
+ (car abbrevs)
+ (gethash (car abbrevs) *symbol-table*))
+ (format nil "Matches: ~{~A~^ ~}"
+ abbrevs)))))
+
+(defun spec-lookup (term &key (type :all))
+ (unless *populated-p*
+ (populate-table))
+ (ecase type
+ (:all
+ (or (gethash term *symbol-table*)
+ (gethash term *section-table*)
+ (gethash term *format-table*)
+ (gethash term *read-macro-table*)
+ (abbrev-lookup term)))
+ (:abbrev
+ (abbrev-lookup term))
+ (:symbol
+ (gethash term *symbol-table*))
+ (:section
+ (gethash term *section-table*))
+ (:format
+ (gethash term *format-table*))
+ (:read-macro
+ (gethash term *read-macro-table*))))
+
+(defun symbol-lookup (term)
+ (spec-lookup term :type :symbol))
Oops, something went wrong.

0 comments on commit d471483

Please sign in to comment.