3rdparties/software/cffi_0.21.0/doc/colorize-lisp-examples.lisp (44246 bytes)
1 ;;; This is code was taken from lisppaste2 and is a quick hack 2 ;;; to colorize lisp examples in the html generated by Texinfo. 3 ;;; It is not general-purpose utility, though it could easily be 4 ;;; turned into one. 5 6 ;;;; colorize-package.lisp 7 8 (defpackage :colorize 9 (:use :common-lisp) 10 (:export :scan-string :format-scan :html-colorization 11 :find-coloring-type :autodetect-coloring-type 12 :coloring-types :scan :scan-any :advance :call-parent-formatter 13 :*coloring-css* :make-background-css :*css-background-class* 14 :colorize-file :colorize-file-to-stream :*version-token*)) 15 16 ;;;; coloring-css.lisp 17 18 (in-package :colorize) 19 20 (defparameter *coloring-css* 21 ".symbol { color: #770055; background-color: transparent; border: 0px; margin: 0px;} 22 a.symbol:link { color: #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 23 a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 24 a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 25 a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 26 .special { color : #FF5000; background-color : inherit; } 27 .keyword { color : #770000; background-color : inherit; } 28 .comment { color : #007777; background-color : inherit; } 29 .string { color : #777777; background-color : inherit; } 30 .character { color : #0055AA; background-color : inherit; } 31 .syntaxerror { color : #FF0000; background-color : inherit; } 32 span.paren1:hover { color : inherit; background-color : #BAFFFF; } 33 span.paren2:hover { color : inherit; background-color : #FFCACA; } 34 span.paren3:hover { color : inherit; background-color : #FFFFBA; } 35 span.paren4:hover { color : inherit; background-color : #CACAFF; } 36 span.paren5:hover { color : inherit; background-color : #CAFFCA; } 37 span.paren6:hover { color : inherit; background-color : #FFBAFF; } 38 ") 39 40 (defvar *css-background-class* "lisp-bg") 41 42 (defun for-css (thing) 43 (if (symbolp thing) (string-downcase (symbol-name thing)) 44 thing)) 45 46 (defun make-background-css (color &key (class *css-background-class*) (extra nil)) 47 (format nil ".~A { background-color: ~A; color: black; ~{~A; ~}}~:*~:*~:* 48 .~A:hover { background-color: ~A; color: black; ~{~A; ~}}~%" 49 class color 50 (mapcar #'(lambda (extra) 51 (format nil "~A : ~{~A ~}" 52 (for-css (first extra)) 53 (mapcar #'for-css (cdr extra)))) 54 extra))) 55 56 ;;;; colorize.lisp 57 58 ;(in-package :colorize) 59 60 (eval-when (:compile-toplevel :load-toplevel :execute) 61 (defparameter *coloring-types* nil) 62 (defparameter *version-token* (gensym))) 63 64 (defclass coloring-type () 65 ((modes :initarg :modes :accessor coloring-type-modes) 66 (default-mode :initarg :default-mode :accessor coloring-type-default-mode) 67 (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions) 68 (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name) 69 (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter) 70 (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil) 71 (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly "")) 72 (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function 73 :initform (constantly nil)) 74 (parent-type :initarg :parent-type :accessor coloring-type-parent-type 75 :initform nil) 76 (visible :initarg :visible :accessor coloring-type-visible 77 :initform t))) 78 79 (defun find-coloring-type (type) 80 (if (typep type 'coloring-type) 81 type 82 (cdr (assoc (symbol-name type) *coloring-types* :test #'string-equal :key #'symbol-name)))) 83 84 (defun autodetect-coloring-type (name) 85 (car 86 (find name *coloring-types* 87 :key #'cdr 88 :test #'(lambda (name type) 89 (and (coloring-type-visible type) 90 (funcall (coloring-type-autodetect-function type) name)))))) 91 92 (defun coloring-types () 93 (loop for type-pair in *coloring-types* 94 if (coloring-type-visible (cdr type-pair)) 95 collect (cons (car type-pair) 96 (coloring-type-fancy-name (cdr type-pair))))) 97 98 (defun (setf find-coloring-type) (new-value type) 99 (if new-value 100 (let ((found (assoc type *coloring-types*))) 101 (if found 102 (setf (cdr found) new-value) 103 (setf *coloring-types* 104 (nconc *coloring-types* 105 (list (cons type new-value)))))) 106 (setf *coloring-types* (remove type *coloring-types* :key #'car)))) 107 108 (defvar *scan-calls* 0) 109 110 (defvar *reset-position* nil) 111 112 (defmacro with-gensyms ((&rest names) &body body) 113 `(let ,(mapcar #'(lambda (name) 114 (list name `(make-symbol ,(symbol-name name)))) names) 115 ,@body)) 116 117 (defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body) 118 (with-gensyms (num items position not-preceded-by string item new-mode until advancing) 119 `(labels ((advance (,num) 120 (setf ,position-place (+ ,position-place ,num)) 121 t) 122 (peek-any (,items &key ,not-preceded-by) 123 (incf *scan-calls*) 124 (let* ((,items (if (stringp ,items) 125 (coerce ,items 'list) ,items)) 126 (,not-preceded-by (if (characterp ,not-preceded-by) 127 (string ,not-preceded-by) ,not-preceded-by)) 128 (,position ,position-place) 129 (,string ,string-param)) 130 (let ((,item (and 131 (< ,position (length ,string)) 132 (find ,string ,items 133 :test #'(lambda (,string ,item) 134 #+nil 135 (format t "looking for ~S in ~S starting at ~S~%" 136 ,item ,string ,position) 137 (if (characterp ,item) 138 (char= (elt ,string ,position) 139 ,item) 140 (search ,item ,string :start2 ,position 141 :end2 (min (length ,string) 142 (+ ,position (length ,item)))))))))) 143 (if (characterp ,item) 144 (setf ,item (string ,item))) 145 (if 146 (if ,item 147 (if ,not-preceded-by 148 (if (>= (- ,position (length ,not-preceded-by)) 0) 149 (not (string= (subseq ,string 150 (- ,position (length ,not-preceded-by)) 151 ,position) 152 ,not-preceded-by)) 153 t) 154 t) 155 nil) 156 ,item 157 (progn 158 (and *reset-position* 159 (setf ,position-place *reset-position*)) 160 nil))))) 161 (scan-any (,items &key ,not-preceded-by) 162 (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by))) 163 (and ,item (advance (length ,item))))) 164 (peek (,item &key ,not-preceded-by) 165 (peek-any (list ,item) :not-preceded-by ,not-preceded-by)) 166 (scan (,item &key ,not-preceded-by) 167 (scan-any (list ,item) :not-preceded-by ,not-preceded-by))) 168 (macrolet ((set-mode (,new-mode &key ,until (,advancing t)) 169 (list 'progn 170 (list 'setf ',mode-place ,new-mode) 171 (list 'setf ',mode-wait-place 172 (list 'lambda (list ',position) 173 (list 'let (list (list '*reset-position* ',position)) 174 (list 'values ,until ,advancing))))))) 175 ,@body)))) 176 177 (defvar *formatter-local-variables*) 178 179 (defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters 180 autodetect parent formatter-variables (formatter-after-hook '(constantly "")) 181 invisible) 182 (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance) 183 `(let ((,parent-type (or (find-coloring-type ,parent) 184 (and ,parent 185 (error "No such coloring type: ~S" ,parent))))) 186 (setf (find-coloring-type ,name) 187 (make-instance 'coloring-type 188 :fancy-name ',fancy-name 189 :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type))) 190 :default-mode (or ',default-mode 191 (if ,parent-type (coloring-type-default-mode ,parent-type))) 192 ,@(if autodetect 193 `(:autodetect-function ,autodetect)) 194 :parent-type ,parent-type 195 :visible (not ,invisible) 196 :formatter-initial-values (lambda nil 197 (list* ,@(mapcar #'(lambda (e) 198 `(cons ',(car e) ,(second e))) 199 formatter-variables) 200 (if ,parent-type 201 (funcall (coloring-type-formatter-initial-values ,parent-type)) 202 nil))) 203 :formatter-after-hook (lambda nil 204 (symbol-macrolet ,(mapcar #'(lambda (e) 205 `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*)))) 206 formatter-variables) 207 (concatenate 'string 208 (funcall ,formatter-after-hook) 209 (if ,parent-type 210 (funcall (coloring-type-formatter-after-hook ,parent-type)) 211 "")))) 212 :term-formatter 213 (symbol-macrolet ,(mapcar #'(lambda (e) 214 `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*)))) 215 formatter-variables) 216 (lambda (,term) 217 (labels ((call-parent-formatter (&optional (,type (car ,term)) 218 (,string (cdr ,term))) 219 (if ,parent-type 220 (funcall (coloring-type-term-formatter ,parent-type) 221 (cons ,type ,string)))) 222 (call-formatter (&optional (,type (car ,term)) 223 (,string (cdr ,term))) 224 (funcall 225 (case (first ,type) 226 ,@formatters 227 (t (lambda (,type text) 228 (call-parent-formatter ,type text)))) 229 ,type ,string))) 230 (call-formatter)))) 231 :transition-functions 232 (list 233 ,@(loop for transition in transitions 234 collect (destructuring-bind (mode &rest table) transition 235 `(cons ',mode 236 (lambda (,current-mode ,string ,position) 237 (let ((,mode-wait (constantly nil)) 238 (,position-foobage ,position)) 239 (with-scanning-functions ,string ,position-foobage 240 ,current-mode ,mode-wait 241 (let ((*reset-position* ,position)) 242 (cond ,@table)) 243 (values ,position-foobage ,current-mode 244 (lambda (,new-position) 245 (setf ,position-foobage ,new-position) 246 (let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage)))) 247 (values ,position-foobage ,advance))))) 248 ))))))))))) 249 250 (defun full-transition-table (coloring-type-object) 251 (let ((parent (coloring-type-parent-type coloring-type-object))) 252 (if parent 253 (append (coloring-type-transition-functions coloring-type-object) 254 (full-transition-table parent)) 255 (coloring-type-transition-functions coloring-type-object)))) 256 257 (defun scan-string (coloring-type string) 258 (let* ((coloring-type-object (or (find-coloring-type coloring-type) 259 (error "No such coloring type: ~S" coloring-type))) 260 (transitions (full-transition-table coloring-type-object)) 261 (result nil) 262 (low-bound 0) 263 (current-mode (coloring-type-default-mode coloring-type-object)) 264 (mode-stack nil) 265 (current-wait (constantly nil)) 266 (wait-stack nil) 267 (current-position 0) 268 (*scan-calls* 0)) 269 (flet ((finish-current (new-position new-mode new-wait &key (extend t) push pop) 270 (let ((to (if extend new-position current-position))) 271 (if (> to low-bound) 272 (setf result (nconc result 273 (list (cons (cons current-mode mode-stack) 274 (subseq string low-bound 275 to)))))) 276 (setf low-bound to) 277 (when pop 278 (pop mode-stack) 279 (pop wait-stack)) 280 (when push 281 (push current-mode mode-stack) 282 (push current-wait wait-stack)) 283 (setf current-mode new-mode 284 current-position new-position 285 current-wait new-wait)))) 286 (loop 287 (if (> current-position (length string)) 288 (return-from scan-string 289 (progn 290 (format *trace-output* "Scan was called ~S times.~%" 291 *scan-calls*) 292 (finish-current (length string) nil (constantly nil)) 293 result)) 294 (or 295 (loop for transition in 296 (mapcar #'cdr 297 (remove current-mode transitions 298 :key #'car 299 :test-not #'(lambda (a b) 300 (or (eql a b) 301 (if (listp b) 302 (member a b)))))) 303 if 304 (and transition 305 (multiple-value-bind 306 (new-position new-mode new-wait) 307 (funcall transition current-mode string current-position) 308 (when (> new-position current-position) 309 (finish-current new-position new-mode new-wait :extend nil :push t) 310 t))) 311 return t) 312 (multiple-value-bind 313 (pos advance) 314 (funcall current-wait current-position) 315 #+nil 316 (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position) 317 (and pos 318 (when (> pos current-position) 319 (finish-current (if advance 320 pos 321 current-position) 322 (car mode-stack) 323 (car wait-stack) 324 :extend advance 325 :pop t) 326 t))) 327 (progn 328 (incf current-position))) 329 ))))) 330 331 (defun format-scan (coloring-type scan) 332 (let* ((coloring-type-object (or (find-coloring-type coloring-type) 333 (error "No such coloring type: ~S" coloring-type))) 334 (color-formatter (coloring-type-term-formatter coloring-type-object)) 335 (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object)))) 336 (format nil "~{~A~}~A" 337 (mapcar color-formatter scan) 338 (funcall (coloring-type-formatter-after-hook coloring-type-object))))) 339 340 (defun encode-for-pre (string) 341 (declare (simple-string string)) 342 (let ((output (make-array (truncate (length string) 2/3) 343 :element-type 'character 344 :adjustable t 345 :fill-pointer 0))) 346 (with-output-to-string (out output) 347 (loop for char across string 348 do (case char 349 ((#\&) (write-string "&" out)) 350 ((#\<) (write-string "<" out)) 351 ((#\>) (write-string ">" out)) 352 ((#\") (write-string """ out)) 353 ((#\RIGHTWARDS_DOUBLE_ARROW) (write-string "⇒" out)) 354 (t (write-char char out))))) 355 (coerce output 'simple-string))) 356 357 (defun string-substitute (string substring replacement-string) 358 "String substitute by Larry Hunter. Obtained from Google" 359 (let ((substring-length (length substring)) 360 (last-end 0) 361 (new-string "")) 362 (do ((next-start 363 (search substring string) 364 (search substring string :start2 last-end))) 365 ((null next-start) 366 (concatenate 'string new-string (subseq string last-end))) 367 (setq new-string 368 (concatenate 'string 369 new-string 370 (subseq string last-end next-start) 371 replacement-string)) 372 (setq last-end (+ next-start substring-length))))) 373 374 (defun decode-from-tt (string) 375 (string-substitute 376 (string-substitute 377 (string-substitute 378 (string-substitute 379 (string-substitute string "&" "&") 380 "<" "<") 381 ">" ">") 382 "⇒" (string #\RIGHTWARDS_DOUBLE_ARROW)) 383 """ "\"")) 384 385 (defun html-colorization (coloring-type string) 386 (format-scan coloring-type 387 (mapcar #'(lambda (p) 388 (cons (car p) 389 (let ((tt (encode-for-pre (cdr p)))) 390 (if (and (> (length tt) 0) 391 (char= (elt tt (1- (length tt))) #\>)) 392 (format nil "~A~%" tt) tt)))) 393 (scan-string coloring-type string)))) 394 395 (defun colorize-file-to-stream (coloring-type input-file-name s2 &key (wrap t) (css-background "default")) 396 (let* ((input-file (if (pathname-type (merge-pathnames input-file-name)) 397 (merge-pathnames input-file-name) 398 (make-pathname :type "lisp" 399 :defaults (merge-pathnames input-file-name)))) 400 (*css-background-class* css-background)) 401 (with-open-file (s input-file :direction :input) 402 (let ((lines nil) 403 (string nil)) 404 (block done 405 (loop (let ((line (read-line s nil nil))) 406 (if line 407 (push line lines) 408 (return-from done))))) 409 (setf string (format nil "~{~A~%~}" 410 (nreverse lines))) 411 (if wrap 412 (format s2 413 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\"> 414 <html><head><style type=\"text/css\">~A~%~A</style><body> 415 <table width=\"100%\"><tr><td class=\"~A\"> 416 <tt>~A</tt> 417 </tr></td></table></body></html>" 418 *coloring-css* 419 (make-background-css "white") 420 *css-background-class* 421 (html-colorization coloring-type string)) 422 (write-string (html-colorization coloring-type string) s2)))))) 423 424 (defun colorize-file (coloring-type input-file-name &optional output-file-name) 425 (let* ((input-file (if (pathname-type (merge-pathnames input-file-name)) 426 (merge-pathnames input-file-name) 427 (make-pathname :type "lisp" 428 :defaults (merge-pathnames input-file-name)))) 429 (output-file (or output-file-name 430 (make-pathname :type "html" 431 :defaults input-file)))) 432 (with-open-file (s2 output-file :direction :output :if-exists :supersede) 433 (colorize-file-to-stream coloring-type input-file-name s2)))) 434 435 ;; coloring-types.lisp 436 437 ;(in-package :colorize) 438 439 (eval-when (:compile-toplevel :load-toplevel :execute) 440 (defparameter *version-token* (gensym))) 441 442 (defparameter *symbol-characters* 443 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890") 444 445 (defparameter *non-constituent* 446 '(#\space #\tab #\newline #\linefeed #\page #\return 447 #\" #\' #\( #\) #\, #\; #\` #\[ #\])) 448 449 (defparameter *special-forms* 450 '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the" 451 "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*" 452 "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally" 453 "return-from" "setq" "multiple-value-call")) 454 455 (defparameter *common-macros* 456 '("loop" "cond" "lambda")) 457 458 (defparameter *open-parens* '(#\()) 459 (defparameter *close-parens* '(#\))) 460 461 (define-coloring-type :lisp "Basic Lisp" 462 :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment 463 :multiline :character 464 :single-escaped :in-list :syntax-error) 465 :default-mode :first-char-on-line 466 :transitions 467 (((:in-list) 468 ((or 469 (scan-any *symbol-characters*) 470 (and (scan #\.) (scan-any *symbol-characters*)) 471 (and (scan #\\) (advance 1))) 472 (set-mode :symbol 473 :until (scan-any *non-constituent*) 474 :advancing nil)) 475 ((or (scan #\:) (scan "#:")) 476 (set-mode :keyword 477 :until (scan-any *non-constituent*) 478 :advancing nil)) 479 ((scan "#\\") 480 (let ((count 0)) 481 (set-mode :character 482 :until (progn 483 (incf count) 484 (if (> count 1) 485 (scan-any *non-constituent*))) 486 :advancing nil))) 487 ((scan #\") 488 (set-mode :string 489 :until (scan #\"))) 490 ((scan #\;) 491 (set-mode :comment 492 :until (scan #\newline))) 493 ((scan "#|") 494 (set-mode :multiline 495 :until (scan "|#"))) 496 ((scan #\() 497 (set-mode :in-list 498 :until (scan #\))))) 499 ((:normal :first-char-on-line) 500 ((scan #\() 501 (set-mode :in-list 502 :until (scan #\))))) 503 (:first-char-on-line 504 ((scan #\;) 505 (set-mode :comment 506 :until (scan #\newline))) 507 ((scan "#|") 508 (set-mode :multiline 509 :until (scan "|#"))) 510 ((advance 1) 511 (set-mode :normal 512 :until (scan #\newline)))) 513 (:multiline 514 ((scan "#|") 515 (set-mode :multiline 516 :until (scan "|#")))) 517 ((:symbol :keyword :escaped-symbol :string) 518 ((scan #\\) 519 (let ((count 0)) 520 (set-mode :single-escaped 521 :until (progn 522 (incf count) 523 (if (< count 2) 524 (advance 1)))))))) 525 :formatter-variables ((paren-counter 0)) 526 :formatter-after-hook (lambda nil 527 (format nil "~{~A~}" 528 (loop for i from paren-counter downto 1 529 collect "</span></span>"))) 530 :formatters 531 (((:normal :first-char-on-line) 532 (lambda (type s) 533 (declare (ignore type)) 534 s)) 535 ((:in-list) 536 (lambda (type s) 537 (declare (ignore type)) 538 (labels ((color-parens (s) 539 (let ((paren-pos (find-if-not #'null 540 (mapcar #'(lambda (c) 541 (position c s)) 542 (append *open-parens* 543 *close-parens*))))) 544 (if paren-pos 545 (let ((before-paren (subseq s 0 paren-pos)) 546 (after-paren (subseq s (1+ paren-pos))) 547 (paren (elt s paren-pos)) 548 (open nil) 549 (count 0)) 550 (when (member paren *open-parens* :test #'char=) 551 (setf count (mod paren-counter 6)) 552 (incf paren-counter) 553 (setf open t)) 554 (when (member paren *close-parens* :test #'char=) 555 (decf paren-counter)) 556 (if open 557 (format nil "~A<span class=\"paren~A\">~C<span class=\"~A\">~A" 558 before-paren 559 (1+ count) 560 paren *css-background-class* 561 (color-parens after-paren)) 562 (format nil "~A</span>~C</span>~A" 563 before-paren 564 paren (color-parens after-paren)))) 565 s)))) 566 (color-parens s)))) 567 ((:symbol :escaped-symbol) 568 (lambda (type s) 569 (declare (ignore type)) 570 (let* ((colon (position #\: s :from-end t)) 571 (new-s (or (and colon (subseq s (1+ colon))) s))) 572 (cond 573 ((or 574 (member new-s *common-macros* :test #'string-equal) 575 (member new-s *special-forms* :test #'string-equal) 576 (some #'(lambda (e) 577 (and (> (length new-s) (length e)) 578 (string-equal e (subseq new-s 0 (length e))))) 579 '("WITH-" "DEF"))) 580 (format nil "<i><span class=\"symbol\">~A</span></i>" s)) 581 ((and (> (length new-s) 2) 582 (char= (elt new-s 0) #\*) 583 (char= (elt new-s (1- (length new-s))) #\*)) 584 (format nil "<span class=\"special\">~A</span>" s)) 585 (t s))))) 586 (:keyword (lambda (type s) 587 (declare (ignore type)) 588 (format nil "<span class=\"keyword\">~A</span>" 589 s))) 590 ((:comment :multiline) 591 (lambda (type s) 592 (declare (ignore type)) 593 (format nil "<span class=\"comment\">~A</span>" 594 s))) 595 ((:character) 596 (lambda (type s) 597 (declare (ignore type)) 598 (format nil "<span class=\"character\">~A</span>" 599 s))) 600 ((:string) 601 (lambda (type s) 602 (declare (ignore type)) 603 (format nil "<span class=\"string\">~A</span>" 604 s))) 605 ((:single-escaped) 606 (lambda (type s) 607 (call-formatter (cdr type) s))) 608 ((:syntax-error) 609 (lambda (type s) 610 (declare (ignore type)) 611 (format nil "<span class=\"syntaxerror\">~A</span>" 612 s))))) 613 614 (define-coloring-type :scheme "Scheme" 615 :autodetect (lambda (text) 616 (or 617 (search "scheme" text :test #'char-equal) 618 (search "chicken" text :test #'char-equal))) 619 :parent :lisp 620 :transitions 621 (((:normal :in-list) 622 ((scan "...") 623 (set-mode :symbol 624 :until (scan-any *non-constituent*) 625 :advancing nil)) 626 ((scan #\[) 627 (set-mode :in-list 628 :until (scan #\]))))) 629 :formatters 630 (((:in-list) 631 (lambda (type s) 632 (declare (ignore type s)) 633 (let ((*open-parens* (cons #\[ *open-parens*)) 634 (*close-parens* (cons #\] *close-parens*))) 635 (call-parent-formatter)))) 636 ((:symbol :escaped-symbol) 637 (lambda (type s) 638 (declare (ignore type)) 639 (let ((result (if (find-package :r5rs-lookup) 640 (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup)) 641 s)))) 642 (if result 643 (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" 644 result (call-parent-formatter)) 645 (call-parent-formatter))))))) 646 647 (define-coloring-type :elisp "Emacs Lisp" 648 :autodetect (lambda (name) 649 (member name '("emacs") 650 :test #'(lambda (name ext) 651 (search ext name :test #'char-equal)))) 652 :parent :lisp 653 :formatters 654 (((:symbol :escaped-symbol) 655 (lambda (type s) 656 (declare (ignore type)) 657 (let ((result (if (find-package :elisp-lookup) 658 (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup)) 659 s)))) 660 (if result 661 (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" 662 result (call-parent-formatter)) 663 (call-parent-formatter))))))) 664 665 (define-coloring-type :common-lisp "Common Lisp" 666 :autodetect (lambda (text) 667 (search "lisp" text :test #'char-equal)) 668 :parent :lisp 669 :transitions 670 (((:normal :in-list) 671 ((scan #\|) 672 (set-mode :escaped-symbol 673 :until (scan #\|))))) 674 :formatters 675 (((:symbol :escaped-symbol) 676 (lambda (type s) 677 (declare (ignore type)) 678 (let* ((colon (position #\: s :from-end t :test #'char=)) 679 (to-lookup (if colon (subseq s (1+ colon)) s)) 680 (result (if (find-package :clhs-lookup) 681 (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup)) 682 to-lookup)))) 683 (if result 684 (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" 685 result (call-parent-formatter)) 686 (call-parent-formatter))))))) 687 688 (define-coloring-type :common-lisp-file "Common Lisp File" 689 :parent :common-lisp 690 :default-mode :in-list 691 :invisible t) 692 693 (defvar *c-open-parens* "([{") 694 (defvar *c-close-parens* ")]}") 695 696 (defvar *c-reserved-words* 697 '("auto" "break" "case" "char" "const" 698 "continue" "default" "do" "double" "else" 699 "enum" "extern" "float" "for" "goto" 700 "if" "int" "long" "register" "return" 701 "short" "signed" "sizeof" "static" "struct" 702 "switch" "typedef" "union" "unsigned" "void" 703 "volatile" "while" "__restrict" "_Bool")) 704 705 (defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") 706 (defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#)) 707 708 (define-coloring-type :basic-c "Basic C" 709 :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor) 710 :default-mode :normal 711 :invisible t 712 :transitions 713 ((:normal 714 ((scan-any *c-begin-word*) 715 (set-mode :word-ish 716 :until (scan-any *c-terminators*) 717 :advancing nil)) 718 ((scan "/*") 719 (set-mode :comment 720 :until (scan "*/"))) 721 ((or 722 (scan-any *c-open-parens*) 723 (scan-any *c-close-parens*)) 724 (set-mode :paren-ish 725 :until (advance 1) 726 :advancing nil)) 727 ((scan #\") 728 (set-mode :string 729 :until (scan #\"))) 730 ((or (scan "'\\") 731 (scan #\')) 732 (set-mode :character 733 :until (advance 2)))) 734 (:string 735 ((scan #\\) 736 (set-mode :single-escape 737 :until (advance 1))))) 738 :formatter-variables 739 ((paren-counter 0)) 740 :formatter-after-hook (lambda nil 741 (format nil "~{~A~}" 742 (loop for i from paren-counter downto 1 743 collect "</span></span>"))) 744 :formatters 745 ((:normal 746 (lambda (type s) 747 (declare (ignore type)) 748 s)) 749 (:comment 750 (lambda (type s) 751 (declare (ignore type)) 752 (format nil "<span class=\"comment\">~A</span>" 753 s))) 754 (:string 755 (lambda (type s) 756 (declare (ignore type)) 757 (format nil "<span class=\"string\">~A</span>" 758 s))) 759 (:character 760 (lambda (type s) 761 (declare (ignore type)) 762 (format nil "<span class=\"character\">~A</span>" 763 s))) 764 (:single-escape 765 (lambda (type s) 766 (call-formatter (cdr type) s))) 767 (:paren-ish 768 (lambda (type s) 769 (declare (ignore type)) 770 (let ((open nil) 771 (count 0)) 772 (if (eql (length s) 1) 773 (progn 774 (when (member (elt s 0) (coerce *c-open-parens* 'list)) 775 (setf open t) 776 (setf count (mod paren-counter 6)) 777 (incf paren-counter)) 778 (when (member (elt s 0) (coerce *c-close-parens* 'list)) 779 (setf open nil) 780 (decf paren-counter) 781 (setf count (mod paren-counter 6))) 782 (if open 783 (format nil "<span class=\"paren~A\">~A<span class=\"~A\">" 784 (1+ count) s *css-background-class*) 785 (format nil "</span>~A</span>" 786 s))) 787 s)))) 788 (:word-ish 789 (lambda (type s) 790 (declare (ignore type)) 791 (if (member s *c-reserved-words* :test #'string=) 792 (format nil "<span class=\"symbol\">~A</span>" s) 793 s))) 794 )) 795 796 (define-coloring-type :c "C" 797 :parent :basic-c 798 :transitions 799 ((:normal 800 ((scan #\#) 801 (set-mode :preprocessor 802 :until (scan-any '(#\return #\newline)))))) 803 :formatters 804 ((:preprocessor 805 (lambda (type s) 806 (declare (ignore type)) 807 (format nil "<span class=\"special\">~A</span>" s))))) 808 809 (defvar *c++-reserved-words* 810 '("asm" "auto" "bool" "break" "case" 811 "catch" "char" "class" "const" "const_cast" 812 "continue" "default" "delete" "do" "double" 813 "dynamic_cast" "else" "enum" "explicit" "export" 814 "extern" "false" "float" "for" "friend" 815 "goto" "if" "inline" "int" "long" 816 "mutable" "namespace" "new" "operator" "private" 817 "protected" "public" "register" "reinterpret_cast" "return" 818 "short" "signed" "sizeof" "static" "static_cast" 819 "struct" "switch" "template" "this" "throw" 820 "true" "try" "typedef" "typeid" "typename" 821 "union" "unsigned" "using" "virtual" "void" 822 "volatile" "wchar_t" "while")) 823 824 (define-coloring-type :c++ "C++" 825 :parent :c 826 :transitions 827 ((:normal 828 ((scan "//") 829 (set-mode :comment 830 :until (scan-any '(#\return #\newline)))))) 831 :formatters 832 ((:word-ish 833 (lambda (type s) 834 (declare (ignore type)) 835 (if (member s *c++-reserved-words* :test #'string=) 836 (format nil "<span class=\"symbol\">~A</span>" 837 s) 838 s))))) 839 840 (defvar *java-reserved-words* 841 '("abstract" "boolean" "break" "byte" "case" 842 "catch" "char" "class" "const" "continue" 843 "default" "do" "double" "else" "extends" 844 "final" "finally" "float" "for" "goto" 845 "if" "implements" "import" "instanceof" "int" 846 "interface" "long" "native" "new" "package" 847 "private" "protected" "public" "return" "short" 848 "static" "strictfp" "super" "switch" "synchronized" 849 "this" "throw" "throws" "transient" "try" 850 "void" "volatile" "while")) 851 852 (define-coloring-type :java "Java" 853 :parent :c++ 854 :formatters 855 ((:word-ish 856 (lambda (type s) 857 (declare (ignore type)) 858 (if (member s *java-reserved-words* :test #'string=) 859 (format nil "<span class=\"symbol\">~A</span>" 860 s) 861 s))))) 862 863 (let ((terminate-next nil)) 864 (define-coloring-type :objective-c "Objective C" 865 :autodetect (lambda (text) (search "mac" text :test #'char=)) 866 :modes (:begin-message-send :end-message-send) 867 :transitions 868 ((:normal 869 ((scan #\[) 870 (set-mode :begin-message-send 871 :until (advance 1) 872 :advancing nil)) 873 ((scan #\]) 874 (set-mode :end-message-send 875 :until (advance 1) 876 :advancing nil)) 877 ((scan-any *c-begin-word*) 878 (set-mode :word-ish 879 :until (or 880 (and (peek-any '(#\:)) 881 (setf terminate-next t)) 882 (and terminate-next (progn 883 (setf terminate-next nil) 884 (advance 1))) 885 (scan-any *c-terminators*)) 886 :advancing nil))) 887 (:word-ish 888 #+nil 889 ((scan #\:) 890 (format t "hi~%") 891 (set-mode :word-ish :until (advance 1) :advancing nil) 892 (setf terminate-next t)))) 893 :parent :c++ 894 :formatter-variables ((is-keyword nil) (in-message-send nil)) 895 :formatters 896 ((:begin-message-send 897 (lambda (type s) 898 (setf is-keyword nil) 899 (setf in-message-send t) 900 (call-formatter (cons :paren-ish type) s))) 901 (:end-message-send 902 (lambda (type s) 903 (setf is-keyword nil) 904 (setf in-message-send nil) 905 (call-formatter (cons :paren-ish type) s))) 906 (:word-ish 907 (lambda (type s) 908 (declare (ignore type)) 909 (prog1 910 (let ((result (if (find-package :cocoa-lookup) 911 (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup)) 912 s)))) 913 (if result 914 (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" 915 result s) 916 (if (member s *c-reserved-words* :test #'string=) 917 (format nil "<span class=\"symbol\">~A</span>" s) 918 (if in-message-send 919 (if is-keyword 920 (format nil "<span class=\"keyword\">~A</span>" s) 921 s) 922 s)))) 923 (setf is-keyword (not is-keyword)))))))) 924 925 926 ;#!/usr/bin/clisp 927 ;#+sbcl 928 ;(require :asdf) 929 ;(asdf:oos 'asdf:load-op :colorize) 930 931 (defmacro with-each-stream-line ((var stream) &body body) 932 (let ((eof (gensym)) 933 (eof-value (gensym)) 934 (strm (gensym))) 935 `(let ((,strm ,stream) 936 (,eof ',eof-value)) 937 (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof))) 938 ((eql ,var ,eof)) 939 ,@body)))) 940 941 (defun system (control-string &rest args) 942 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and 943 synchronously execute the result using a Bourne-compatible shell, with 944 output to *verbose-out*. Returns the shell's exit code." 945 (let ((command (apply #'format nil control-string args))) 946 (format t "; $ ~A~%" command) 947 #+sbcl 948 (sb-impl::process-exit-code 949 (sb-ext:run-program 950 "/bin/sh" 951 (list "-c" command) 952 :input nil :output *standard-output*)) 953 #+(or cmucl scl) 954 (ext:process-exit-code 955 (ext:run-program 956 "/bin/sh" 957 (list "-c" command) 958 :input nil :output *verbose-out*)) 959 #+clisp ;XXX not exactly *verbose-out*, I know 960 (ext:run-shell-command command :output :terminal :wait t) 961 )) 962 963 (defun strcat (&rest strings) 964 (apply #'concatenate 'string strings)) 965 966 (defun string-starts-with (start str) 967 (and (>= (length str) (length start)) 968 (string-equal start str :end2 (length start)))) 969 970 (defmacro string-append (outputstr &rest args) 971 `(setq ,outputstr (concatenate 'string ,outputstr ,@args))) 972 973 (defconstant +indent+ 0 974 "Indentation used in the examples.") 975 976 (defun texinfo->raw-lisp (code) 977 "Answer CODE with spurious Texinfo output removed. For use in 978 preprocessing output in a @lisp block before passing to colorize." 979 (decode-from-tt 980 (with-output-to-string (output) 981 (do* ((last-position 0) 982 (next-position 983 #0=(search #1="<span class=\"roman\">" code 984 :start2 last-position :test #'char-equal) 985 #0#)) 986 ((eq nil next-position) 987 (write-string code output :start last-position)) 988 (write-string code output :start last-position :end next-position) 989 (let ((end (search #2="</span>" code 990 :start2 (+ next-position (length #1#)) 991 :test #'char-equal))) 992 (assert (integerp end) () 993 "Missing ~A tag in HTML for @lisp block~%~ 994 HTML contents of block:~%~A" #2# code) 995 (write-string code output 996 :start (+ next-position (length #1#)) 997 :end end) 998 (setf last-position (+ end (length #2#)))))))) 999 1000 (defun process-file (from to) 1001 (with-open-file (output to :direction :output :if-exists :error) 1002 (with-open-file (input from :direction :input) 1003 (let ((line-processor nil) 1004 (piece-of-code '())) 1005 (labels 1006 ((process-line-inside-pre (line) 1007 (cond ((string-starts-with "</pre>" line) 1008 (with-input-from-string 1009 (stream (colorize:html-colorization 1010 :common-lisp 1011 (texinfo->raw-lisp 1012 (apply #'concatenate 'string 1013 (nreverse piece-of-code))))) 1014 (with-each-stream-line (cline stream) 1015 (format output " ~A~%" cline))) 1016 (write-line line output) 1017 (setq piece-of-code '() 1018 line-processor #'process-regular-line)) 1019 (t (let ((to-append (subseq line +indent+))) 1020 (push (if (string= "" to-append) 1021 " " 1022 to-append) piece-of-code) 1023 (push (string #\Newline) piece-of-code))))) 1024 (process-regular-line (line) 1025 (let ((len (some (lambda (test-string) 1026 (when (string-starts-with test-string line) 1027 (length test-string))) 1028 '("<pre class=\"lisp\">" 1029 "<pre class=\"smalllisp\">")))) 1030 (cond (len 1031 (setq line-processor #'process-line-inside-pre) 1032 (write-string "<pre class=\"lisp\">" output) 1033 (push (subseq line (+ len +indent+)) piece-of-code) 1034 (push (string #\Newline) piece-of-code)) 1035 (t (write-line line output)))))) 1036 (setf line-processor #'process-regular-line) 1037 (with-each-stream-line (line input) 1038 (funcall line-processor line))))))) 1039 1040 (defun process-dir (dir) 1041 (dolist (html-file (directory dir)) 1042 (let* ((name (namestring html-file)) 1043 (temp-name (strcat name ".temp"))) 1044 (process-file name temp-name) 1045 (system "mv ~A ~A" temp-name name)))) 1046 1047 ;; (go "/tmp/doc/manual/html_node/*.html") 1048 1049 #+clisp 1050 (progn 1051 (assert (first ext:*args*)) 1052 (process-dir (first ext:*args*))) 1053 1054 #+sbcl 1055 (progn 1056 (assert (second sb-ext:*posix-argv*)) 1057 (process-dir (second sb-ext:*posix-argv*)) 1058 (sb-ext:quit))