;;; Count and collect names and ages. (loop for name in '(fred sue alice joe june) as age in '(22 26 19 20 10) append (list name age) into name-and-age-list count name into name-count sum age into total-age finally (return (values (round total-age name-count) name-and-age-list))) ; special form and constant (setq x (+ 3 2 1) y (cons x nil)) ; type (series 'b 'c) => #Z(b c b c b c ...) (scan (list 'a 'b 'c)) => #Z(a b c) ; declaration specifier (defun simple-collect-sum (numbers) (declare (optimizable-series-function 1)) (collect-fn 'number #'(lambda () 0) #'+ numbers)) ; global variables (let ((*print-right-margin* 25) (*print-lines* 3)) (pprint '(progn (setq a 1 b 2 c 3 d 4)))) #2A((0 1 5) (foo #4r4056 (hot dog))) ; user-defined variable (setf *temp* (function *)) ; keyword arguments (write foo :pretty t :right-margin 60 :case :downcase) ;;; cl-typesetting copyright 2003-2004 Marc Battyani see license.txt for the details ;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net ;;; The homepage of cl-typesetting is here: http://www.fractalconcept.com/asp/html/cl-typesetting.html (in-package #:typeset) ;;; This is a module to typeset Common Lisp code with some syntax coloring ;;; The syntax coloring is too simple to be 100% accurate: ;;; Improvements welcomed! (defparameter *pp-font-size* 9) (defparameter *pp-default-decoration* '("courier" (0.0 0.0 0.0))) (defparameter *pp-keyword-decoration* '("courier" (0.8 0.0 0.0))) (defparameter *pp-common-lisp-decoration* '("courier" (0.0 0.0 0.4))) (defparameter *pp-string-decoration* '("courier" (0.0 0.5 0.0))) (defparameter *pp-comment-decoration* '("courier" (0.2 0.2 0.6))) (defparameter *pp-symbol-decoration-table* (make-hash-table)) (defparameter *exceptions* '()) (defun add-symbol-decoration (symbol decoration) (setf (gethash symbol *pp-symbol-decoration-table*) decoration)) ;(loop for (symbol . decoration) in '((defvar "courier-bold" (0.0 0.0 0.5)) ; (defun "courier-bold" (0.0 0.2 0.5)) ; (defmethod "courier-bold" (0.0 0.2 0.5))) ; do (add-symbol-decoration symbol decoration)) (loop for symbol being the external-symbols of 'common-lisp when (eql (search "DEF" (symbol-name symbol)) 0) do (add-symbol-decoration symbol '("courier-bold" (0.0 0.2 0.5)))) (defun split-comment (line) (let ((comment-pos (position #\; line))) (if comment-pos (values (subseq line 0 comment-pos)(subseq line comment-pos)) line))) (defun clean-line (line) (setf line (copy-seq line)) (map-into line #'(lambda (char) (if (find char "()'`# ") #\Space char)) line)) (defun process-lisp-line (line) (multiple-value-bind (code comment)(split-comment line) (let* ((cleaned-line (clean-line code)) (cl-package (find-package 'common-lisp)) (decorations '()) (start 0) (trimmed 0) (length (length cleaned-line))) (iter (setf trimmed (position #\Space cleaned-line :start start :test #'char/=)) (while (and trimmed (< trimmed length))) (for (values obj end) = (ignore-errors (read-from-string cleaned-line nil nil :start trimmed :preserve-whitespace t))) (unless (numberp end) (setf end (position #\Space cleaned-line :start trimmed :test #'char=))) (while (and (numberp end) (< end length))) (cond ((keywordp obj) (push (list* trimmed end *pp-keyword-decoration*) decorations)) ((stringp obj) (push (list* trimmed end *pp-string-decoration*) decorations)) ((gethash obj *pp-symbol-decoration-table*) (push (list* trimmed end (gethash obj *pp-symbol-decoration-table*)) decorations)) ((and (symbolp obj) (or (eq (symbol-package obj) cl-package) (member (symbol-name obj) '("FOR" "THEN" "WHILE" "COLLECT" "IN" "WITH" "FINALLY") :test #'string=)) (not (member (symbol-name obj) *exceptions* :test #'string=))) (push (list* trimmed end *pp-common-lisp-decoration*) decorations))) (setf start end)) (setf start 0) (loop for (start-tok end-tok font-name color) in (nreverse decorations) do (when (/= start start-tok) (with-text-compilation (verbatim (subseq line start start-tok)))) (with-text-compilation (with-style (:font font-name :font-size *pp-font-size* :color color) (verbatim (subseq line start-tok end-tok)))) (setf start end-tok)) (with-text-compilation (when (< start length) (verbatim (subseq code start))) (with-style (:font (first *pp-comment-decoration*) :font-size *pp-font-size* :color (second *pp-comment-decoration*)) (verbatim comment) (when (zerop length) (verbatim " ")) :eol))))) (defmethod process-lisp-code ((s stream)) (with-text-compilation (paragraph (:h-align :left :top-margin 10 :left-margin 5 :right-margin 5 :font "courier" :font-size *pp-font-size*) (loop for line = (read-line s nil) while line do (with-text-compilation (process-lisp-line line)))))) (defmethod process-lisp-code ((lisp-file pathname)) (with-open-file (s lisp-file :direction :input) (process-lisp-code s))) (defmethod process-lisp-code ((lisp-string string)) (with-input-from-string (s lisp-string) (process-lisp-code s))) (defmethod process-lisp-code ((sexpr t)) (process-lisp-code (with-output-to-string (s) (pprint sexpr s)))) (defun pprint-lisp-file (lisp-code pdf-file &optional title *exceptions*) (with-document () (let* ((margins '(30 50 30 50)) (print-stamp (multiple-value-bind (second minute hour date month year) (get-decoded-time) (declare (ignore second)) (format nil "Printed on ~4D-~2,'0D-~2,'0D ~2,'0D:~2,'0D" year month date hour minute))) (header (compile-text () (paragraph (:h-align :center :font "Helvetica-BoldOblique" :font-size 12) (put-string (cond (title title) ((pathnamep lisp-code)(namestring lisp-code)) (t "Lisp Source Code")))) (vspace 1) (hrule :dy 0.5))) (footer (lambda (pdf:*page*) (compile-text (:font "Helvetica" :font-size 10) (hrule :dy 1/2) (hbox (:align :center :adjustable-p t) (verbatim print-stamp) :hfill (verbatim (format nil "Page ~d" pdf:*page-number*)))))) (content (compile-text () (process-lisp-code lisp-code)))) (draw-pages content :margins margins :header header :footer footer) (when pdf:*page* (finalize-page pdf:*page*)) (pdf:write-document pdf-file))))