;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10; Encoding: latin-1; -*- ;;; $Header: /usr/local/cvsrep/weitz.de/macros.lisp,v 1.18 2008/05/06 21:28:26 edi Exp $ (in-package :cl-user) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; THE POWER OF LISP MACROS ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 1. What makes Lisp different ;;; ---------------------------- ;;; ;;; ;;; ;;; - A notation for code as trees of symbols ;;; - The whole language always available (read, compile, run) ;;; ;;; Aims of this talk: ;;; ;;; - Give 30 minute intro to macros for Lisp "newbies" ;;; (while sweeping several details under the rug) ;;; - Show what's cool about them ;;; (the macros, not the newbies...) ;;; - Whet your appetite for more (see URLs) ;;; See also: ;;; ;;; - Casting SPELs in Lisp ;;; ;;; - Practical Common Lisp ;;; ;;; 2. A function is not enough ;;; --------------------------- ;;; ;;; Adding new control constructs to the language (defun red-button () (capi:display-message "BOOM! Game Over...")) (if (= 1 1) "No worries..." (red-button)) (defun my-if (test-form then-form else-form) (cond (test-form then-form) (t else-form))) (my-if (= 1 1) "No worries..." (red-button)) ;;; Oops... (defmacro my-if (test-form then-form else-form) ;; in "reality" IF is a "special operator" and COND is a macro (list 'cond (list test-form then-form) (list t else-form))) ;;; Now try to MACROEXPAND-1 this: (my-if (= 1 1) "No worries..." (red-button)) ;;; That's better... :) (defmacro my-if (test-form then-form else-form) `(cond (,test-form ,then-form) (t ,else-form))) ;;; More sophisticated examples: ;;; ;;; - The LOOP macro ;;; (see for example SBCL source code at ) ;;; - Baker: Metacircular Semantics for CL Special Forms ;;; ;;; 3. The classic: WITH- ;;; --------------------- ;;; ;;; Wrap a body of code with a prologue ;;; and a (guaranteed) happy ending (defun begin-transaction () (format t "Starting transaction~%")) (defun commit-transaction () (format t "Committing transaction~%")) (defun abort-transaction () (format t "Aborting transaction~%")) (defmacro with-transaction (&body body) `(let (done) ; variable capture - see below (unwind-protect (prog2 (begin-transaction) (progn ,@body) (setq done t)) (if done (commit-transaction) (abort-transaction))))) (defvar *in-transaction-p* nil) (defmacro with-transaction (&body body) `(let (done) ; variable capture - see below (flet ((body-fn () ,@body)) (cond (*in-transaction-p* (body-fn)) (t (unwind-protect (let ((*in-transaction-p* t)) (prog2 (begin-transaction) (body-fn) (setq done t))) (if done (commit-transaction) (abort-transaction)))))))) ;;; See also: ;;; ;;; - Typical UNWIND-PROTECT macros: ;;; - WITH-OPEN-FILE (ANSI standard) ;;; ;;; - WITH-LOCK/WITH-MUTEX (usually in Lisps with MP support) ;;; ;;; - WITH-DYNAMIC-FOREIGN-OBJECTS (LispWorks FLI) ;;; ;;; - WITH-TIMEOUT (e.g. in ACL-COMPAT) ;;; ;;; - Other WITH- macros: ;;; - WITH-ACCESSORS (ANSI standard) ;;; ;;; - WITH-STANDARD-IO-SYNTAX (ANSI standard) ;;; ;;; - WITH-OUTPUT-TO-STRING (ANSI standard) ;;; ;;; - WITH-HTML-OUTPUT (CL-WHO) ;;; ;;; - lots more... ;;; 4. Ensuring discretion ;;; ---------------------- ;;; ;;; Avoiding variable capture (let ((done 42)) (with-transaction (incf done)) done) ;;; Ouch... (defmacro with-transaction (&body body) (let ((done (gensym))) `(let (,done) (flet ((body-fn () ,@body)) (cond (*in-transaction-p* (body-fn)) (t (unwind-protect (let ((*in-transaction-p* t)) (prog2 (begin-transaction) (body-fn) (setq ,done t))) (if ,done (commit-transaction) (abort-transaction))))))))) ;;; But we can do that with a macro as well... :) (defmacro with-unique-names* (vars &body body) ;; LispWorks already has WITH-UNIQUE-NAMES... `(let ,(loop for var in vars collect `(,var (gensym ,(symbol-name var)))) ,@body)) (defmacro with-transaction (&body body) (with-unique-names* (done) `(let (,done) (flet ((body-fn () ,@body)) (cond (*in-transaction-p* (body-fn)) (t (unwind-protect (let ((*in-transaction-p* t)) (prog2 (begin-transaction) (body-fn) (setq ,done t))) (if ,done (commit-transaction) (abort-transaction))))))))) ;;; See also: ;;; ;;; - REBINDING ;;; e.g. at ;;; - various LET-like constructs ;;; e.g. ;;; or ;;; 5. To macro or not to macro ;;; --------------------------- ;;; ;;; Don't use macros when functions will do (defun one+ (x) (1+ x)) (mapcar 'one+ '(1 2 3)) (funcall #'one+ 41) ;;; Look, ma, no function call overhead: (defmacro one+ (x) `(1+ ,x)) (mapcar 'one+ '(1 2 3)) (funcall #'one+ 41) ;;; Cough... ;;; Alternatives: ;;; ;;; - INLINE (see ANSI standard) ;;; ;;; - Compiler macros (see below) ;;; 6. A (well, very simple) unit test framework in 21 seconds ;;; ---------------------------------------------------------- ;;; ;;; Execute compiled code at run time and keep the source as well (defvar *test-thunks* (make-hash-table)) ; (defvar *test-sources* (make-hash-table)) (defmacro define-test (name (&optional condition) &body body) (with-unique-names (c) `(setf (gethash ',name *test-sources*) '(progn ,@body) (gethash ',name *test-thunks*) (lambda () (handler-case (format t "Test ~A ~:[FAILED~;passed~].~%" ',name (progn ,@body)) ,@(when condition `((,condition () (format t "Test ~A passed.~%" ',name)))) (error (,c) (format t "Test ~A FAILED, ~ condition ~S was signalled.~%" ',name ,c))))))) (defun run-tests () (dolist (test-name (sort (loop for name being the hash-keys of *test-thunks* collect name) #'string-lessp)) (format t "~%~%Starting test ~A...~%" test-name) (let ((*print-pretty* t)) (format t "~S~%~%" (gethash test-name *test-sources*))) (funcall (gethash test-name *test-thunks*))) (values)) (define-test simple-plus-test () (= (+ 1 1) 2)) (define-test wake-up-after-sleep () (sleep 1) t) (define-test division-by-zero (division-by-zero) (let ((a 42) (b 41)) (incf b) (/ 1 (- a b)))) (define-test unknown-file () ;; this is a Windows laptop... (open "/etc/passwd")) (run-tests) ;;; See also: ;;; ;;; - "Real" test frameworks ;;; ;;; - Some other things that look like DEFUN: ;;; - DEF-FUNCTION (UFFI) ;;; ;;; - DEFINE-EASY-HANDLER (Hunchentoot) ;;; ;;; - DEFINE-PLUGIN-FUNCTION (FM-PLUGIN-TOOLS) ;;; ;;; - lots more... ;;; 7. Your HTML tutor ;;; ------------------ ;;; ;;; Macros writing macros (defmacro emit-html ((tag &rest attributes) &body body) `(progn (format t "<~(~A~)" ',tag) ,@(loop for (key value) on attributes by #'cddr when value collect (rebinding (value) `(format t " ~(~A~)~:[=\"~A\"~;~]" ',key (eq ,value t) ,value))) (format t ">") ,@(loop for expr in body when (stringp expr) collect `(format t ,expr) else collect expr) ,@(when body `((format t "" ',tag))) (terpri t))) (emit-html (hr :align "left" :noshade t)) (emit-html (p :align "left") "Part one" (emit-html (br)) "Part two" (emit-html (hr :size (+ 39 3) :noshade nil)) "The end") (defmacro define-html-tag (tag &rest attr-list) (let* ((no-body (find :no-body attr-list :test #'string-equal)) (attr-list (remove :no-body attr-list :test #'string-equal)) (attr-args (loop for attr-name in attr-list collect (list 'quote attr-name) collect attr-name))) (with-unique-names (body) `(defmacro ,tag ((&key ,@attr-list) ,@(unless no-body `(&body ,body))) `(emit-html (,',tag ,,@attr-args) ,@,(unless no-body body)))))) (define-html-tag hr no-body align noshade size) (define-html-tag br no-body clear) (define-html-tag p align) ;;; note argument list display in IDE: (p (:align "left") "Part one" (br ()) "Part two" (hr (:size (+ 40 2) :noshade t)) "The end") ;;; Other HTML macros ;;; at ;;; 8. For your speed only ;;; ---------------------- ;;; ;;; Compiler macros - transform code to help the compiler (defun add-vat (amount &key (tax-rate .19)) (* (+ 1 tax-rate) amount)) (defun add-vat% (amount tax-rate) (format t "Function with simple lambda list called...~%") (* (+ 1 tax-rate) amount)) (define-compiler-macro add-vat (amount &key (tax-rate .19)) `(add-vat% ,amount ,tax-rate)) (defun vat-test () (format t "Test 1~%") (format t "=> ~A~%" (add-vat 30000 :tax-rate .16)) (format t "~%Test 2~%") (let ((more-args (list :tax-rate .16))) (format t "=> ~A~%" (apply #'add-vat 30000 more-args)))) ;;; see (asdf:oos 'asdf:load-op :cl-ppcre) (trace ppcre::create-scanner) (ppcre:scan "^\\s*[a-z]+\\s*$" " abc ") (defun several-scans (&rest strings) (loop for string in strings count (ppcre:scan "^\\s*[a-z]+\\s*$" string))) ;;; See also: ;;; ;;; - Talk by Arthur Lemmens with several examples ;;; ;;; 9. What you see is not always what you get ;;; ------------------------------------------ ;;; ;;; Reader macros "The present-day composer refuses to die.\n\n\t\t\tEdgar Varèse" (defun new-double-quote-reader (stream macro-char) (declare (ignore macro-char)) (with-output-to-string (out) (loop for char = (read-char stream t nil t) while (char/= char #\") do (write-char (cond ((char= char #\\) (let ((next-char (read-char stream t nil t))) (case next-char (#\t #\Tab) (#\n #\Newline) (otherwise next-char)))) (t char)) out)))) (set-macro-character #\" 'new-double-quote-reader) ;;; See also: ;;; ;;; - Symbolic SQL syntax (LispWorks Common SQL / CLSQL) ;;; ;;; ;;; ;;; - Embedded XML (XMLisp) ;;; ;;; - Embedded .NET calls (RDNZL) ;;; ;;; - Shell-like variable interpolations (CL-INTERPOL) ;;; ;;; - Internationalization ;;; 10. Don't try this at home ;;; -------------------------- ;;; ;;; Macros for black belts ;;; - "On Lisp" ;;; - Screamer ;;; - Series ;;; - Iterate ;;; The latest version of this document is available from ;;; . ;;; Note that the code snippets above are quick hacks for demo ;;; purposes; you should /not/ assume they're error-free or even ;;; production-quality. ;;; This talk was originally given at the company Christmas party 2006 ;;; of freiheit.com technologies gmbh. ;;; Thanks to Arthur Lemmens for various suggestions for this talk. ;;; Copyright (c) 2006, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use of this text in its orginal form (plain ;;; text) or in 'derived' forms (HTML, PDF, Postscript, RTF and so ;;; forth) with or without modification, are permitted provided that ;;; the following condition is met: ;;; * Redistributions must reproduce the above copyright notice, this ;;; condition and the following disclaimer in the document itself ;;; and/or other materials provided with the distribution. ;;; THIS DOCUMENT IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; DOCUMENTATION, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.