First commit

LICENSE.txt

@@ -0,0 +1,27 @@
+Freeware License, some rights reserved
+
+Copyright (c) 2005 Peter Seibel
+
+Permission is hereby granted, free of charge, to anyone obtaining a copy 
+of this software and associated documentation files (the "Software"), 
+to work with the Software within the limits of freeware distribution and fair use. 
+This includes the rights to use, copy, and modify the Software for personal use. 
+Users are also allowed and encouraged to submit corrections and modifications 
+to the Software for the benefit of other users.
+
+It is not allowed to reuse,  modify, or redistribute the Software for 
+commercial use in any way, or for a user�s educational materials such as books 
+or blog articles without prior permission from the copyright holder. 
+
+The above copyright notice and this permission notice need to be included 
+in all copies or substantial portions of the software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS OR APRESS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+
+

README.md

@@ -0,0 +1,15 @@
+#Apress Source Code
+
+This repository accompanies [*Practical Common Lisp*](http://www.apress.com/9781590592397) by Peter Seibel (Apress, 2005).
+
+![Cover image](9781590592397.jpg)
+
+Download the files as a zip using the green button, or clone the repository to your machine using Git.
+
+##Releases
+
+Release v1.0 corresponds to the code in the published book, without corrections or updates.
+
+##Contributions
+
+See the file Contributing.md for more information on how you can contribute to this repository.

contributing.md

@@ -0,0 +1,14 @@
+# Contributing to Apress Source Code
+
+Copyright for Apress source code belongs to the author(s). However, under fair use you are encouraged to fork and contribute minor corrections and updates for the benefit of the author(s) and other readers.
+
+## How to Contribute
+
+1. Make sure you have a GitHub account.
+2. Fork the repository for the relevant book.
+3. Create a new branch on which to make your change, e.g. 
+`git checkout -b my_code_contribution`
+4. Commit your change. Include a commit message describing the correction. Please note that if your commit message is not clear, the correction will not be accepted.
+5. Submit a pull request.
+
+Thank you for your contribution!

practicals/Chapter03/packages.lisp

@@ -0,0 +1,3 @@
+(in-package :cl-user)
+
+(defpackage :com.gigamonkeys.simple-db (:use :cl))

practicals/Chapter03/simple-database.asd

@@ -0,0 +1,16 @@
+(defpackage :com.gigamonkeys.simple-database-system (:use :asdf :cl))
+(in-package :com.gigamonkeys.simple-database-system)
+
+(defsystem simple-database
+  :name "simple-database"
+  :author "Peter Seibel <peter@gigamonkeys.com>"
+  :version "1.0"
+  :maintainer "Peter Seibel <peter@gigamonkeys.com>"
+  :licence "BSD"
+  :description "Simple s-expression database."
+  :long-description ""
+  :components
+  ((:file "packages")
+   (:file "simple-database" :depends-on ("packages"))))
+
+

practicals/Chapter03/simple-database.lisp

@@ -0,0 +1,73 @@
+(in-package :com.gigamonkeys.simple-db)
+
+(defvar *db* nil)
+
+(defun make-cd (title artist rating ripped)
+  (list :title title :artist artist :rating rating :ripped ripped))
+
+(defun add-record (cd) (push cd *db*))
+
+(defun dump-db ()
+  (dolist (cd *db*)
+    (format t "~{~a:~10t~a~%~}~%" cd)))
+
+(defun prompt-read (prompt)
+  (format *query-io* "~a: " prompt)
+  (force-output *query-io*)
+  (read-line *query-io*))
+
+(defun prompt-for-cd ()
+  (make-cd
+   (prompt-read "Title")
+   (prompt-read "Artist")
+   (or (parse-integer (prompt-read "Rating") :junk-allowed t) 0)
+   (y-or-n-p "Ripped [y/n]: ")))
+
+(defun add-cds ()
+  (loop (add-record (prompt-for-cd))
+     (if (not (y-or-n-p "Another? [y/n]: ")) (return))))
+
+(defun save-db (filename)
+  (with-open-file (out filename 
+                   :direction :output
+                   :if-exists :supersede)
+    (with-standard-io-syntax
+      (print *db* out))))
+
+(defun load-db (filename)
+  (with-open-file (in filename)
+    (with-standard-io-syntax
+      (setf *db* (read in)))))
+
+(defun clear-db () (setq *db* nil))
+
+(defun select (selector-fn)
+  (remove-if-not selector-fn *db*))
+
+(defmacro where (&rest clauses)
+  `#'(lambda (cd) (and ,@(make-comparisons-list clauses))))
+
+(defun make-comparisons-list (fields)
+  (loop while fields
+     collecting (make-comparison-expr (pop fields) (pop fields))))
+
+(defun make-comparison-expr (field value)
+  `(equal (getf cd ,field) ,value))
+
+
+(defun update (selector-fn &key title artist rating (ripped nil ripped-p))
+  (setf *db*
+        (mapcar 
+         #'(lambda (row)
+             (when (funcall selector-fn row)
+               (if title    (setf (getf row :title) title))
+               (if artist   (setf (getf row :artist) artist))
+               (if rating   (setf (getf row :rating) rating))
+               (if ripped-p (setf (getf row :ripped) ripped)))
+             row) *db*)))
+
+(defun delete-rows (selector-fn)
+  (setf *db* (remove-if selector-fn *db*)))
+
+
+

practicals/Chapter08/macro-utilities.asd

@@ -0,0 +1,17 @@
+(defpackage :com.gigamonkeys.macro-utilities-system (:use :asdf :cl))
+(in-package :com.gigamonkeys.macro-utilities-system)
+
+(defsystem macro-utilities
+  :name "macro-utilities"
+  :author "Peter Seibel <peter@gigamonkeys.com>"
+  :version "1.0"
+  :maintainer "Peter Seibel <peter@gigamonkeys.com>"
+  :licence "BSD"
+  :description "Utilities for writing macros"
+  :long-description ""
+  :components
+  ((:file "packages")
+   (:file "macro-utilities" :depends-on ("packages")))
+  :depends-on ())
+
+

practicals/Chapter08/macro-utilities.lisp

@@ -0,0 +1,28 @@
+(in-package :com.gigamonkeys.macro-utilities)
+
+(defmacro with-gensyms ((&rest names) &body body)
+  `(let ,(loop for n in names collect `(,n (make-symbol ,(string n))))
+     ,@body))
+
+(defmacro once-only ((&rest names) &body body)
+  (let ((gensyms (loop for n in names collect (gensym (string n)))))
+    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
+      `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
+        ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
+           ,@body)))))
+
+(defun spliceable (value)
+  (if value (list value)))
+
+(defmacro ppme (form &environment env)
+  (progn
+    (write (macroexpand-1 form env)
+           :length nil
+           :level nil
+           :circle nil
+           :pretty t
+           :gensym nil
+           :right-margin 83
+           :case :downcase)
+    nil))
+

practicals/Chapter08/packages.lisp

@@ -0,0 +1,11 @@
+(in-package :cl-user)
+
+(defpackage :com.gigamonkeys.macro-utilities
+  (:use :common-lisp)
+  (:export 
+   :with-gensyms
+   :with-gensymed-defuns
+   :once-only
+   :spliceable
+   :ppme))
+

practicals/Chapter09/packages.lisp

@@ -0,0 +1,5 @@
+(in-package :cl-user)
+
+(defpackage :com.gigamonkeys.test
+  (:use :common-lisp :com.gigamonkeys.macro-utilities)
+  (:export :deftest :check))

practicals/Chapter09/test-framework.asd

@@ -0,0 +1,15 @@
+(defpackage :com.gigamonkeys.test-system (:use :asdf :cl))
+(in-package :com.gigamonkeys.test-system)
+
+(defsystem test-framework
+  :name "test-framework"
+  :author "Peter Seibel <peter@gigamonkeys.com>"
+  :version "1.0"
+  :maintainer "Peter Seibel <peter@gigamonkeys.com>"
+  :licence "BSD"
+  :description "Simple unit test framework for Common Lisp"
+  :long-description ""
+  :components
+  ((:file "packages")
+   (:file "test" :depends-on ("packages")))
+  :depends-on (:macro-utilities))

practicals/Chapter09/test.lisp

@@ -0,0 +1,27 @@
+(in-package :com.gigamonkeys.test)
+
+(defvar *test-name* nil)
+
+(defmacro deftest (name parameters &body body)
+  "Define a test function. Within a test function we can call other
+test functions or use `check' to run individual test cases."
+  `(defun ,name ,parameters
+    (let ((*test-name* (append *test-name* (list ',name))))
+      ,@body)))
+
+(defmacro check (&body forms)
+  "Run each expression in `forms' as a test case."
+  `(combine-results
+    ,@(loop for f in forms collect `(report-result ,f ',f))))
+
+(defmacro combine-results (&body forms)
+  "Combine the results (as booleans) of evaluating `forms' in order."
+  (with-gensyms (result)
+    `(let ((,result t))
+      ,@(loop for f in forms collect `(unless ,f (setf ,result nil)))
+      ,result)))
+
+(defun report-result (result form)
+  "Report the results of a single test case. Called by `check'."
+  (format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form)
+  result)

practicals/Chapter15/packages.lisp

@@ -0,0 +1,14 @@
+(in-package :cl-user)
+
+(defpackage :com.gigamonkeys.pathnames
+  (:use :common-lisp)
+  (:export
+   :list-directory
+   :file-exists-p
+   :directory-pathname-p
+   :file-pathname-p
+   :pathname-as-directory
+   :pathname-as-file
+   :walk-directory
+   :directory-p
+   :file-p))

practicals/Chapter15/pathnames.asd

@@ -0,0 +1,17 @@
+(defpackage :com.gigamonkeys.pathnames-system (:use :asdf :cl))
+(in-package :com.gigamonkeys.pathnames-system)
+
+(defsystem pathnames
+  :name "pathnames"
+  :author "Peter Seibel <peter@gigamonkeys.com>"
+  :version "1.0"
+  :maintainer "Peter Seibel <peter@gigamonkeys.com>"
+  :licence "BSD"
+  :description "Portable pathname manipulation functions."
+  :long-description ""
+  :components
+  ((:file "packages")
+   (:file "pathnames" :depends-on ("packages"))))
+
+
+