├── LICENSE.txt ├── code ├── errata.pdf ├── chapter-19 │ ├── callback.c │ ├── swap.c │ ├── convert.c │ ├── complex.c │ ├── note.xml │ ├── test2.c │ ├── test.c │ ├── sum.c │ └── factorial.c ├── chapter-10 │ └── foo.lisp ├── chapter-15 │ ├── prepare2.sh │ ├── prepare.sh │ ├── foo.lisp │ └── code.lisp ├── chapter-03 │ ├── test.csv │ └── code.lisp ├── chapter-22 │ ├── deliver.lisp │ ├── test2.c │ ├── hello.lisp │ ├── filter.c │ ├── test.c │ ├── Test.java │ └── code.lisp ├── chapter-20 │ ├── PointSetter.java │ ├── index.html │ ├── Mandelbrot.java │ └── code.lisp ├── chapter-14 │ ├── fdata.c │ └── data.c ├── chapter-17 │ ├── foo.lisp │ └── code.lisp ├── README.txt ├── chapter-18 │ └── code.lisp ├── chapter-05 │ └── code.lisp ├── chapter-21 │ └── code.lisp ├── chapter-16 │ └── code.lisp ├── chapter-08 │ └── code.lisp ├── chapter-04 │ └── code.lisp ├── chapter-01 │ └── code.lisp ├── chapter-11 │ └── code.lisp ├── chapter-02 │ └── code.lisp ├── chapter-12 │ └── code.lisp └── chapter-06 │ └── code.lisp ├── 9781484211779.jpg ├── README.md └── contributing.md /LICENSE.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/common-lisp-recipes/HEAD/LICENSE.txt -------------------------------------------------------------------------------- /code/errata.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/common-lisp-recipes/HEAD/code/errata.pdf -------------------------------------------------------------------------------- /9781484211779.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/common-lisp-recipes/HEAD/9781484211779.jpg -------------------------------------------------------------------------------- /code/chapter-19/callback.c: -------------------------------------------------------------------------------- 1 | void test (int n, void (*func)(int)) { 2 | (*func)(n * n); 3 | } 4 | -------------------------------------------------------------------------------- /code/chapter-10/foo.lisp: -------------------------------------------------------------------------------- 1 | (defun test () 2 | (print (load-time-value (get-internal-real-time)))) 3 | -------------------------------------------------------------------------------- /code/chapter-19/swap.c: -------------------------------------------------------------------------------- 1 | void swap (int *a, int *b) { 2 | int t = *b; 3 | *b = *a; 4 | *a = t; 5 | } 6 | -------------------------------------------------------------------------------- /code/chapter-15/prepare2.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | cd /tmp 3 | rm -rf foo quux 4 | mkdir -p foo/bar 5 | ln -s foo/bar quux 6 | -------------------------------------------------------------------------------- /code/chapter-03/test.csv: -------------------------------------------------------------------------------- 1 | "a string",3,3.2 2 | "another string","string with \"quotes\"",12 3 | "string, with comma","",3.5E3 4 | -------------------------------------------------------------------------------- /code/chapter-22/deliver.lisp: -------------------------------------------------------------------------------- 1 | (load (compile-file "code.lisp")) 2 | (lw:deliver nil "my_lib" 0 :dll-exports '("toLispTime")) 3 | -------------------------------------------------------------------------------- /code/chapter-20/PointSetter.java: -------------------------------------------------------------------------------- 1 | package de.weitz; 2 | 3 | public interface PointSetter { 4 | public void fill(boolean points[][]); 5 | } 6 | -------------------------------------------------------------------------------- /code/chapter-15/prepare.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | cd /tmp 3 | rm -f foo* bar* quux* 4 | echo "Waka/Jawaka" > foo.txt 5 | ln -s foo.txt bar.txt 6 | ln -s bar.txt quux.txt 7 | -------------------------------------------------------------------------------- /code/chapter-19/convert.c: -------------------------------------------------------------------------------- 1 | void convert (unsigned char in[], unsigned int out[]) { 2 | int i = 0; 3 | while (in[i]) { 4 | out[i] = in[i]; 5 | i++; 6 | } 7 | out[i] = 0; 8 | } 9 | -------------------------------------------------------------------------------- /code/chapter-19/complex.c: -------------------------------------------------------------------------------- 1 | struct complex { 2 | double real; 3 | double imag; 4 | }; 5 | 6 | double magnitude_squared (struct complex *c) { 7 | return c->real * c->real + c->imag * c->imag; 8 | } 9 | -------------------------------------------------------------------------------- /code/chapter-22/test2.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main () { 4 | extern long toLispTime(int, int, int); 5 | printf("Date 1940-12-21 is Lisp time %ld.\n", 6 | toLispTime(1940, 12, 21)); 7 | return 0; 8 | } 9 | -------------------------------------------------------------------------------- /code/chapter-22/hello.lisp: -------------------------------------------------------------------------------- 1 | #-:abcl 2 | (defun hello () 3 | (format t "Hello World!~%The time is ~A.~%" (get-universal-time))) 4 | 5 | #+:abcl 6 | (defun hello (name) 7 | (format nil "Hello ~A!~%The time is ~A.~%" 8 | name (get-universal-time))) 9 | -------------------------------------------------------------------------------- /code/chapter-22/filter.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main (void) { 4 | int c; 5 | while ((c = getchar()) != EOF) { 6 | putchar(c); 7 | if (c == '\n') 8 | fflush(stdout); 9 | else 10 | putchar(c); 11 | } 12 | return 0; 13 | } 14 | -------------------------------------------------------------------------------- /code/chapter-19/note.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | Fur Trapper 4 | 5 | Warning 6 | Don't Eat The Yellow Snow! 7 | 8 | Nanook 9 | 10 | -------------------------------------------------------------------------------- /code/chapter-19/test2.c: -------------------------------------------------------------------------------- 1 | /* 2 | * compile with: 3 | * gcc -fpic -shared test2.c -o test2.so 4 | */ 5 | 6 | double power(int exponent) { 7 | int i; 8 | double result = 1.0; 9 | for (i = 1; i <= exponent; i++) 10 | result *= 2.0; 11 | return result; 12 | } 13 | -------------------------------------------------------------------------------- /code/chapter-15/foo.lisp: -------------------------------------------------------------------------------- 1 | (defparameter *foo* *load-pathname*) 2 | 3 | ;; remove comment, then delete FASL: 4 | ;; (defparameter *bar* *compile-file-pathname*) 5 | 6 | ;; alternative, see book: 7 | ;; (eval-when (:compile-toplevel) 8 | ;; (defparameter *bar* *compile-file-pathname*)) 9 | -------------------------------------------------------------------------------- /code/chapter-19/test.c: -------------------------------------------------------------------------------- 1 | /* 2 | * compile with: 3 | * gcc -fpic -shared test.c -o test.so 4 | */ 5 | 6 | double power (double base, int exponent) { 7 | int i; 8 | double result = 1.0; 9 | 10 | for (i = 1; i <= exponent; i++) 11 | result *= base; 12 | return result; 13 | } 14 | -------------------------------------------------------------------------------- /code/chapter-22/test.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main (int argc, char **argv) { 4 | extern void init_mylib(cl_object); 5 | cl_boot(argc, argv); 6 | ecl_init_module(NULL, init_mylib); 7 | cl_eval(c_string_to_object("(hello)")); 8 | cl_shutdown(); 9 | return 0; 10 | } 11 | -------------------------------------------------------------------------------- /code/chapter-14/fdata.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main (int argc, char* argv[]) { 4 | double x = 42.5E9; 5 | double y = -.89E-12; 6 | 7 | FILE* out = fopen("/tmp/data", "w"); 8 | 9 | fwrite(&x, sizeof(x), 1, out); 10 | fwrite(&y, sizeof(y), 1, out); 11 | 12 | fclose(out); 13 | } 14 | -------------------------------------------------------------------------------- /code/chapter-19/sum.c: -------------------------------------------------------------------------------- 1 | double sum (double *arr, int size) { 2 | int i; 3 | double result = 0.0; 4 | for (i = 0; i < size; i++) { 5 | result += arr[i]; 6 | } 7 | return result; 8 | } 9 | 10 | double set_arr (double *arr, int index, double new_value) { 11 | arr[index] = new_value; 12 | return new_value; 13 | } 14 | -------------------------------------------------------------------------------- /code/chapter-14/data.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | struct foo { 4 | char tag; 5 | unsigned short x0; 6 | unsigned short y0; 7 | long size; 8 | }; 9 | 10 | int main (int argc, char* argv[]) { 11 | static struct foo foo1 = {'x', 12, 24, -666}; 12 | static struct foo foo2 = {'A', 42, 1, 1234567810}; 13 | 14 | FILE* out = fopen("/tmp/data", "w"); 15 | 16 | fwrite(&foo1, sizeof(struct foo), 1, out); 17 | fwrite(&foo2, sizeof(struct foo), 1, out); 18 | 19 | fclose(out); 20 | } 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Apress Source Code 2 | 3 | This repository accompanies [*Common Lisp Recipes*](http://www.apress.com/9781484211779) by Edmund Weitz (Apress, 2016). 4 | 5 | ![Cover image](9781484211779.jpg) 6 | 7 | Download the files as a zip using the green button, or clone the repository to your machine using Git. 8 | 9 | ## Releases 10 | 11 | Release v1.0 corresponds to the code in the published book, without corrections or updates. 12 | 13 | ## Contributions 14 | 15 | See the file Contributing.md for more information on how you can contribute to this repository. 16 | -------------------------------------------------------------------------------- /code/chapter-22/Test.java: -------------------------------------------------------------------------------- 1 | import org.armedbear.lisp.*; 2 | 3 | public class Test { 4 | public static void main(String arg[]) { 5 | Interpreter interpreter = Interpreter.createInstance(); 6 | interpreter.eval("(load \"hello.lisp\")"); 7 | Function hello = (Function) Packages.findPackage("CL-USER") 8 | .findAccessibleSymbol("HELLO") 9 | .getSymbolFunction(); 10 | LispObject result = hello.execute(new SimpleString("ABCL")); 11 | System.out.print(result.princToString()); 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /code/chapter-19/factorial.c: -------------------------------------------------------------------------------- 1 | union result_union { 2 | double rval; 3 | unsigned long ival; 4 | }; 5 | 6 | struct result_struct { 7 | char exact; 8 | union result_union val; 9 | }; 10 | 11 | void factorial (int n, struct result_struct *r) { 12 | int i; 13 | // assumes long has 64 bits 14 | if (n < 21) { 15 | unsigned long result = 1; 16 | for (i = 1; i <= n; i++) 17 | result *= i; 18 | r->exact = 1; 19 | r->val.ival = result; 20 | } else { 21 | double result = 1.0; 22 | for (i = 1; i <= n; i++) 23 | result *= i; 24 | r->exact = 0; 25 | r->val.rval = result; 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /code/chapter-20/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 7 | 8 | 9 | 16 | 17 | 18 |
19 | 20 |
21 | 22 | 23 | -------------------------------------------------------------------------------- /code/chapter-17/foo.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :foo 2 | (:use :cl) 3 | (:export :main)) 4 | 5 | (in-package :foo) 6 | 7 | (defun foo-1 (n) 8 | (loop for i below (* 1000 n) maximize i)) 9 | 10 | (defun foo-2 (n) 11 | (loop for i below n sum i)) 12 | 13 | (defun foo-3 (n) 14 | (loop for i below n sum (foo-2 i))) 15 | 16 | (defun bar-1 (n) 17 | (loop for i below n sum (foo-1 i))) 18 | 19 | (defun bar-2 (n) 20 | (loop for i below n sum (foo-3 i))) 21 | 22 | (defun baz-1 (n) 23 | (bar-2 (* 10 n))) 24 | 25 | (defun baz-2 (n) 26 | (if (zerop n) 27 | (baz-1 1) 28 | (+ (bar-1 n) (baz-2 (1- n))))) 29 | 30 | (defun main (n) 31 | (loop for i below n 32 | sum (+ (baz-1 i) (baz-2 i)))) 33 | -------------------------------------------------------------------------------- /contributing.md: -------------------------------------------------------------------------------- 1 | # Contributing to Apress Source Code 2 | 3 | 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. 4 | 5 | ## How to Contribute 6 | 7 | 1. Make sure you have a GitHub account. 8 | 2. Fork the repository for the relevant book. 9 | 3. Create a new branch on which to make your change, e.g. 10 | `git checkout -b my_code_contribution` 11 | 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. 12 | 5. Submit a pull request. 13 | 14 | Thank you for your contribution! -------------------------------------------------------------------------------- /code/README.txt: -------------------------------------------------------------------------------- 1 | This directory contains example code for the book "Common Lisp 2 | Recipes" by Edmund Weitz. 3 | 4 | Note that this is NOT code that's meant to be actually used. Some of 5 | it is even defective or inefficient on purpose. These are just 6 | fragments intended to save you some typing if you want to follow the 7 | book's text. 8 | 9 | If the code doesn't agree exactly with what you see in the book, 10 | you're probably looking at an updated version. Please check the 11 | errata and addenda at . 12 | 13 | Most files consist only of ASCII characters. The few exceptions are 14 | UTF-8 encoded and should open up in Emacs without problems. 15 | 16 | There's a main file "code.lisp" for each chapter. Some directories 17 | also include additional Lisp code files and maybe also HTML files or 18 | C, C++, or Java code. 19 | -------------------------------------------------------------------------------- /code/chapter-20/Mandelbrot.java: -------------------------------------------------------------------------------- 1 | package de.weitz; 2 | import javax.swing.*; 3 | import java.awt.*; 4 | 5 | class Plane extends JPanel { 6 | int size; 7 | boolean points[][]; 8 | Plane(PointSetter ps, int size) { 9 | this.size = size; 10 | this.points = new boolean[size][size]; 11 | ps.fill(points); 12 | this.setPreferredSize(new Dimension(size, size)); 13 | } 14 | public void paintComponent(Graphics g) { 15 | super.paintComponent(g); 16 | for (int x = 0; x < size; x++) { 17 | for (int y = 0; y < size; y++) { 18 | ((Graphics2D) g).setPaint(points[x][y] ? 19 | Color.black : Color.white); 20 | ((Graphics2D) g).drawLine(x, y, x, y); 21 | } 22 | } 23 | } 24 | } 25 | 26 | public class Mandelbrot extends JFrame { 27 | public Mandelbrot(PointSetter ps, int size) { 28 | final Plane plane = new Plane(ps, size); 29 | add(plane); 30 | setTitle("Mandelbrot"); 31 | pack(); 32 | } 33 | public void display() { 34 | javax.swing.SwingUtilities.invokeLater(new Runnable() { 35 | public void run() { 36 | setVisible(true); 37 | } 38 | }); 39 | } 40 | } 41 | -------------------------------------------------------------------------------- /code/chapter-20/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | ;; see file "index.html" in this directory 13 | (hunchentoot:start 14 | (make-instance 'hunchentoot:easy-acceptor 15 | :document-root "/path/to/gui/" 16 | :port 4242)) 17 | 18 | (hunchentoot:define-easy-handler (get-symbols :uri "/get-symbols") 19 | (term) 20 | (setf (hunchentoot:content-type*) "application/json") 21 | (with-output-to-string (*standard-output*) 22 | (yason:encode 23 | (sort 24 | (mapcar 'string-downcase (apropos-list term :cl)) 25 | 'string<)))) 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | (defparameter *size* 400) 31 | 32 | (defun gui () 33 | (ltk:with-ltk () 34 | (let* ((vals (list 2 3 4)) 35 | (canvas (ltk:make-canvas nil :width *size* :height *size*)) 36 | (spinbox 37 | (make-instance 'ltk:spinbox 38 | :width 3 39 | :command (lambda (val) 40 | (sierpinski canvas 41 | (parse-integer val))) 42 | :master nil 43 | :values vals 44 | :text (first vals)))) 45 | (ltk:wm-title ltk:*tk* "Sierpinski") 46 | (ltk:configure canvas :background :white) 47 | (ltk:pack canvas) 48 | (ltk:pack spinbox) 49 | (sierpinski canvas (first vals))))) 50 | 51 | (defun sierpinski (canvas level) 52 | (ltk:clear canvas) 53 | (labels ((square (x y size) 54 | (let ((rectangle 55 | (ltk:create-rectangle canvas x y 56 | (+ x size) (+ y size)))) 57 | (ltk:itemconfigure canvas rectangle :fill :red) 58 | (ltk:itemconfigure canvas rectangle :outline :red))) 59 | (recurse (x y size level) 60 | (let ((step (* 1/3 size))) 61 | (square (+ x step) (+ y step) step) 62 | (when (plusp level) 63 | (dolist (next-x (list x (+ x step) (+ x step step))) 64 | (dolist (next-y (list y (+ y step) (+ y step step))) 65 | (recurse next-x next-y step (1- level)))))))) 66 | (recurse 0 0 *size* level))) 67 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 68 | 69 | 70 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 71 | (require 'abcl-contrib) 72 | (require 'jss) 73 | (use-package :jss) 74 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 75 | 76 | 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | (defun say-hello () 79 | (let ((frame (new 'JFrame "Hello ABCL")) 80 | (label (new 'JLabel 81 | "The crux of the biscuit is the apostrophe."))) 82 | (#"add" (#"getContentPane" frame) label) 83 | (#"pack" frame) 84 | (#"setVisible" frame t))) 85 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 86 | 87 | 88 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 89 | (#"invokeLater" 'SwingUtilities 90 | (jinterface-implementation "java.lang.Runnable" 91 | "run" #'say-hello)) 92 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 93 | 94 | 95 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 96 | ;; see Java files in this directory 97 | (add-to-classpath "/tmp/") 98 | (require 'abcl-contrib) 99 | (require 'jss) 100 | (use-package :jss) 101 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 102 | 103 | 104 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 | (defparameter *size* 400) 106 | 107 | (defun set-points (java-array) 108 | (loop for x from -2d0 to 1d0 by (/ 3d0 *size*) 109 | for i from 0 do 110 | (loop for y from 1.5d0 downto -1.5d0 by (/ 3d0 *size*) 111 | for j from 0 112 | for c = (complex x y) 113 | when (loop repeat 100 114 | for z = c then (+ (* z z) c) 115 | always (< (abs z) 2d0)) do 116 | (jarray-set java-array +true+ i j)))) 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 118 | 119 | 120 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 121 | (let ((mandelbrot 122 | (new "de.weitz.Mandelbrot" 123 | (jinterface-implementation "de.weitz.PointSetter" 124 | "fill" #'set-points) 125 | *size*))) 126 | (#"display" mandelbrot)) 127 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 128 | 129 | 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | (defclass node () 132 | ((value :initarg :value 133 | :reader value) 134 | (children :initform nil 135 | :accessor children))) 136 | 137 | (defmethod print-object ((node node) stream) 138 | (with-slots (value) node 139 | (format stream "~A/~A" (numerator value) (denominator value)))) 140 | 141 | (defmethod add-children ((node node)) 142 | (let* ((numerator (numerator (value node))) 143 | (denominator (denominator (value node))) 144 | (sum (+ numerator denominator))) 145 | (setf (children node) 146 | (list (make-instance 'node :value (/ numerator sum)) 147 | (make-instance 'node :value (/ sum denominator)))))) 148 | 149 | (defun one () 150 | (make-instance 'node :value 1)) 151 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 152 | 153 | 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | (capi:define-interface calkin-wilf-tree () 156 | () 157 | (:panes 158 | (tree 159 | capi:tree-view 160 | :reader tree 161 | :roots (list (one)) 162 | :children-function #'children 163 | :action-callback (lambda (node interface) 164 | (unless (children node) 165 | (add-children node) 166 | (capi:tree-view-update-item (tree interface) 167 | node nil))) 168 | :action-callback-expand-p t) 169 | (reset-button 170 | capi:push-button 171 | :text "Reset" 172 | :callback-type :interface 173 | :callback (lambda (interface) 174 | (setf (capi:tree-view-roots 175 | (tree interface)) 176 | (list (one)))))) 177 | (:layouts 178 | (default-layout 179 | capi:column-layout 180 | '(tree reset-button) 181 | :adjust :center)) 182 | (:default-initargs 183 | :best-width 400 184 | :best-height 400 185 | :title "Calkin-Wilf Tree")) 186 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 187 | 188 | 189 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 190 | (capi:display (make-instance 'calkin-wilf-tree)) 191 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 192 | -------------------------------------------------------------------------------- /code/chapter-18/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (require :asdf) 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | (quicklisp-quickstart:install) 18 | (ql:add-to-init-file) 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | 21 | 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | (ql:quickload "quickproject") 24 | (quickproject:make-project "/tmp/fnork/" 25 | :depends-on '(drakma lparallel)) 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | (alexandria:plist-hash-table '(batman gotham-city 31 | superman metropolis 32 | spider-man new-york-city) 33 | :test 'eq) 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | 36 | 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | (alexandria:when-let (symbol (find-symbol "LET")) 39 | (symbol-package symbol)) 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | 42 | 43 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 | (let ((mod3 (alexandria:rcurry 'mod 3))) 45 | (funcall mod3 5)) 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | 48 | 49 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 50 | (defparameter *a* (list 1 2 3 4 5)) 51 | (alexandria:appendf *a* (list 6 7 9)) 52 | *a* 53 | (setf (alexandria:lastcar *a*) 8) 54 | *a* 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | 57 | 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | (alexandria:shuffle (list 1 2 3 4 5 6)) 60 | (alexandria:map-combinations 61 | (lambda (subseq) 62 | (format t "~{~A~^-~}~%" subseq)) 63 | '(1 2 3 4 5) 64 | :length 3) 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | 67 | 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 | (alexandria:lerp 1/10 40 60) 70 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 71 | 72 | 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | (ppcre:scan "([aeiou])\\1" "This example is too simple and cheesy.") 75 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 76 | 77 | 78 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | (pprint (ppcre:parse-string "([a-z])|42+")) 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | 82 | 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | (ppcre:scan "a|b+" string) 85 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 86 | 87 | 88 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 89 | (defun foo-1 (regex) 90 | (dotimes (i 100000) 91 | (ppcre:scan regex "Frunobulax"))) 92 | 93 | (defun foo-2 () 94 | (dotimes (i 100000) 95 | (ppcre:scan "a|b+" "Frunobulax"))) 96 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 97 | 98 | 99 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 100 | (ppcre:scan-to-strings "([aeiou])\\1" 101 | "This example is too simple and cheesy.") 102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 | 104 | 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | (ppcre:all-matches-as-strings "([aeiou])\\1" 107 | "This example is too simple and cheesy.") 108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 109 | 110 | 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | (defun digital-root-1 (target-string) 113 | (let ((sum 0)) 114 | (ppcre:do-matches-as-strings (match :digit-class target-string) 115 | (incf sum (parse-integer match))) 116 | (if (< sum 10) 117 | sum 118 | (digital-root-1 (princ-to-string sum))))) 119 | 120 | (defun digital-root-2 (target-string) 121 | (let ((sum 0)) 122 | (ppcre:do-matches (start end :digit-class target-string) 123 | (incf sum (parse-integer target-string :start start :end end))) 124 | (if (< sum 10) 125 | sum 126 | (digital-root-2 (princ-to-string sum))))) 127 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 128 | 129 | 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | (ppcre:split "\\W+" "The quick brown 132 | fox 133 | jumps over the lazy dog.") 134 | (ppcre:regex-replace-all "[aeiou]" "foul" "e") 135 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 136 | 137 | 138 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 | (drakma:http-request "http://weitz.de/erdos.html") 140 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 141 | 142 | 143 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 144 | (with-open-file (out "/tmp/lisp_logo.jpg" 145 | :element-type '(unsigned-byte 8) 146 | :direction :output) 147 | (cl-fad:copy-stream 148 | (flexi-streams:flexi-stream-stream 149 | (drakma:http-request "http://weitz.de/regex-coach/lisp_logo.jpg" 150 | :want-stream t)) 151 | out)) 152 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 153 | 154 | 155 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | (cl-html-parse:parse-html 157 | (drakma:http-request "http://lisp.org")) 158 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | 160 | 161 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 162 | (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor 163 | :port 4242)) 164 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 165 | 166 | 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | (hunchentoot:define-easy-handler (test-handler :uri "/test") 169 | ((name :init-form "Pumpkin")) 170 | (format nil " 171 | Common Lisp Recipes 172 | Yo, ~A! The Lisp time is ~A." 173 | name (get-universal-time))) 174 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 175 | 176 | 177 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 178 | (defun my-other-handler () 179 | " 180 | Common Lisp Recipes 181 | I'm a constant string.") 182 | 183 | (push (hunchentoot:create-prefix-dispatcher "/foo" 'my-other-handler) 184 | hunchentoot:*dispatch-table*) 185 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 186 | 187 | 188 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 189 | (defun my-other-handler () 190 | (format nil " 191 | Common Lisp Recipes 192 | I'm not a constant string.
193 | And these were the GET parameters:~{ ~S~}." 194 | (hunchentoot:get-parameters*))) 195 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 196 | 197 | 198 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 199 | (ql:quickload "hunchentoot-test") 200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201 | 202 | 203 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 204 | (defun my-other-handler () 205 | (let ((template " 206 | Common Lisp Recipes 207 | I'm not a constant string.
208 | And these were the GET parameters: 209 | 210 | 211 | 212 | ")) 213 | (clip:process-to-string 214 | template :params (hunchentoot:get-parameters*)))) 215 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 216 | 217 | 218 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 219 | (defun my-other-handler () 220 | (cl-markup:html5 221 | (:title "Common Lisp Recipes") 222 | (:body "I'm not a constant string." (:br) 223 | "And these were the GET parameters: " 224 | (loop for param in (hunchentoot:get-parameters*) 225 | collect (cl-markup:markup 226 | (:span (prin1-to-string param)))) 227 | "."))) 228 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 229 | -------------------------------------------------------------------------------- /code/chapter-05/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (defparameter *hours* (make-array '(365 24))) 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | 16 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | (setf (aref *hours* 41 2) "foo") 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | 20 | 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | (let ((a (make-array '(4 5 6)))) 23 | (list (array-total-size a) 24 | (array-rank a) 25 | (array-dimensions a) 26 | (array-dimension a 1))) 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | (defun my-array-dimension (array i) 32 | (nth i (array-dimensions array))) 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | 35 | 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | (defun my-array-rank (array) 38 | (length (array-dimensions array))) 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | 41 | 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | (defun my-array-total-size (array) 44 | (reduce #'* (array-dimensions array) :initial-value 1)) 45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 46 | 47 | 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | (let ((a (make-array 10 :fill-pointer 3))) 50 | (list (array-total-size a) 51 | (length a))) 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | 54 | 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | (make-array '(8 8) :initial-element #\x) 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | 59 | 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | (make-array '(2 3) :initial-contents '((2 3 5) (7 11 13))) 62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | 64 | 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | (make-array '(2 3) :initial-contents '((1 2 3) (4 5 6))) 67 | (make-array '(3 2) :initial-contents '((1 2) (3 4) (5 6))) 68 | (make-array '(2 3 2) 69 | :initial-contents '(((1 2) (3 4) (5 6)) 70 | ((7 8) (9 10) (11 12)))) 71 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | 73 | 74 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 75 | (make-array '(2 3) :initial-contents '#(#(1 2 3) #(4 5 6))) 76 | (make-array '(2 3) :initial-contents '#((1 2 3) (4 5 6))) 77 | (make-array '(2 3) :initial-contents '#(#(1 2 3) (4 5 6))) 78 | (make-array '(2 3) :initial-contents '((1 2 3) #(4 5 6))) 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | 81 | 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | (let ((a (make-array '(4 4) :initial-element (list 1 2 3)))) 84 | (setf (second (aref a 0 1)) 42) 85 | (aref a 2 2)) 86 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 87 | 88 | 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | (let ((a (make-array '(4 4)))) 91 | ;; initialize array 92 | (dotimes (i 16) 93 | (setf (row-major-aref a i) (list 1 2 3))) 94 | ;; now the same test as above 95 | (setf (second (aref a 0 1)) 42) 96 | (aref a 2 2)) 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | 99 | 100 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 101 | (let ((a (make-array '(20 10)))) 102 | (dotimes (i 20) 103 | (dotimes (j 10) 104 | (setf (aref a i j) (* i j)))) 105 | (list (aref a 6 7) 106 | (row-major-aref a 67))) 107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 | 109 | 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | (make-array '(3 2 4) :initial-contents '((( 2 3 5 7) 112 | (11 13 17 19)) 113 | ((23 29 31 37) 114 | (41 43 47 53)) 115 | ((59 61 67 71) 116 | (73 79 83 89)))) 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 118 | 119 | 120 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 121 | (make-array '(4 6) :initial-contents '(( 2 3 5 7 11 13) 122 | (17 19 23 29 31 37) 123 | (41 43 47 53 59 61) 124 | (67 71 73 79 83 89))) 125 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 126 | 127 | 128 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | (let ((a (make-array '(5 10 20)))) 130 | (dotimes (i 5) 131 | (dotimes (j 10) 132 | (dotimes (k 20) 133 | (setf (aref a i j k) (* i j k))))) 134 | (list (aref a 2 3 7) 135 | (row-major-aref a (array-row-major-index a 2 3 7)))) 136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 137 | 138 | 139 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 | (let ((a (make-array 10 :fill-pointer 3))) 141 | (print (length a)) 142 | (vector-push 42 a) 143 | (print (length a)) 144 | (aref a 3)) 145 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 146 | 147 | 148 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 149 | (let ((a (make-array 30 150 | :initial-contents 151 | (loop for i below 30 collect i) 152 | :fill-pointer 20))) 153 | (print (aref a 23)) 154 | (find 23 a)) 155 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | 157 | 158 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | (let ((a (make-array 10 :fill-pointer 0))) 160 | (print (length a)) 161 | (dotimes (i 3) 162 | (vector-push (* i i) a)) 163 | (list (length a) 164 | (vector-pop a) 165 | (length a))) 166 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 167 | 168 | 169 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 170 | (defun adjust-test (adjustable) 171 | (let* ((a (make-array '(4 6) 172 | :initial-element 42 173 | :adjustable adjustable)) 174 | (b (adjust-array a '(5 5) :initial-element 23))) 175 | (list (array-dimensions b) 176 | (eq a b) 177 | (array-dimensions a) 178 | (aref b 1 1) 179 | (aref b 4 4)))) 180 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 181 | 182 | 183 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 184 | (defun my-adjust-array (old-array new-dimensions &key initial-element) 185 | (let ((new-array (make-array new-dimensions 186 | :initial-element initial-element)) 187 | (copy-dimensions (mapcar #'min new-dimensions 188 | (array-dimensions old-array)))) 189 | (labels ((copy-elements (indices dimensions) 190 | (if dimensions 191 | (dotimes (i (first dimensions)) 192 | (copy-elements (cons i indices) (rest dimensions))) 193 | (setf (apply #'aref new-array (reverse indices)) 194 | (apply #'aref old-array (reverse indices)))))) 195 | (copy-elements nil copy-dimensions) 196 | new-array))) 197 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 198 | 199 | 200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201 | (let* ((a (make-array '(5 5))) 202 | (b (make-array '(3 6) 203 | :displaced-to a 204 | :displaced-index-offset 4))) 205 | (dotimes (i 5) 206 | (dotimes (j 5) 207 | (setf (aref a i j) (+ (* 10 (1+ i)) (1+ j))))) 208 | (print (list (aref a 3 1) (aref b 2 0))) 209 | (setf (aref b 2 0) 23) 210 | (aref a 3 1)) 211 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 212 | 213 | 214 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 215 | (make-array '(100 100) :element-type 'double-float) 216 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 217 | 218 | 219 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 220 | (let ((a (make-array 10 :element-type '(unsigned-byte 3)))) 221 | (array-element-type a)) 222 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 223 | 224 | 225 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 226 | (let* ((a (make-array 3 :initial-contents '(1 2 3))) 227 | (b (copy-seq a))) 228 | (setf (aref b 1) 42) 229 | (list a b (eq a b))) 230 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 231 | 232 | 233 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 234 | (defun copy-array (array) 235 | (let ((dimensions (array-dimensions array))) 236 | (adjust-array (make-array dimensions 237 | :element-type (array-element-type array) 238 | :displaced-to array) 239 | dimensions))) 240 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 241 | 242 | 243 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 244 | (let* ((a (make-array 3 :initial-contents (list (list 1 2) 3 4))) 245 | (b (copy-seq a))) 246 | (setf (nth 1 (aref a 0)) 42) 247 | (list a b)) 248 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 249 | -------------------------------------------------------------------------------- /code/chapter-21/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (defclass quux () ((a :initarg :a :reader a))) 13 | (defpackage frob) 14 | (defparameter *thing* 15 | (let* ((list (list :foo)) 16 | (hash (make-hash-table))) 17 | (setf (gethash 42 hash) list) 18 | (vector #\x "x" (make-instance 'quux :a 42) 19 | (intern "X" :frob) list hash))) 20 | (cl-store:store *thing* "/tmp/store") 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | ;; continued from above 26 | (defparameter *other-thing* 27 | (cl-store:restore "/tmp/store")) 28 | *other-thing* 29 | (eq (aref *other-thing* 4) 30 | (gethash 42 (aref *other-thing* 5))) 31 | (a (aref *other-thing* 2)) 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | 34 | 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | (cl-store:restore "/tmp/store") 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | (defparameter *thing* 42 | (let* ((list (list :foo)) 43 | (hash (make-hash-table))) 44 | (setf (gethash 42 hash) list) 45 | (vector (find-package :frob) (find-class 'quux) ;; <- added 46 | #\x "x" (make-instance 'quux :a 42) 47 | (intern "X" :frob) list hash))) 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | 50 | 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | (clsql:connect '("/tmp/worldcup.db") :database-type :sqlite3) 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | 55 | 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | (clsql:def-view-class final () 58 | ((city :accessor city 59 | :initarg :city 60 | :type string) 61 | (year :accessor year 62 | :initarg :year 63 | :db-kind :key 64 | :type integer) 65 | (winner :accessor winner 66 | :initarg :winner 67 | :type keyword))) 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 | 70 | 71 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | (clsql:create-view-from-class 'final) 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | 75 | 76 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 77 | (make-instance 'final :city "Rome" :year 1934 :winner :ita) 78 | (clsql:update-records-from-instance *) 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | 81 | 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | (let ((clsql:*db-auto-sync* t)) 84 | (loop for (city year winner) in '(("Paris" 1938 :ita) 85 | ("Bern" 1954 :deu) 86 | ("Solna" 1958 :bra) 87 | ("Santiago" 1962 :bra) 88 | ("Mexico City" 1970 :bra) 89 | ("Munich" 1974 :deu) 90 | ("Madrid" 1982 :ita) 91 | ("Rome" 1990 :deu) 92 | ("Pasadena" 1994 :bra) 93 | ("Yokohama" 2002 :bra) 94 | ("Berlin" 2006 :ita) 95 | ("Rio" 2014 :deu)) 96 | for final = (make-instance 'final :city city 97 | :year year 98 | :winner winner) 99 | finally (return final))) 100 | ;; oh wait, we made a mistake in the last object; let's fix it: 101 | (let ((clsql:*db-auto-sync* t)) 102 | (setf (city *) "Rio de Janeiro")) 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | 105 | 106 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 107 | (clsql:select 'final :flatp t) 108 | (describe (first (last *))) 109 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 110 | 111 | 112 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 113 | ;; this is for the [...] syntax used below 114 | (clsql:enable-sql-reader-syntax) 115 | (clsql:select 'final :where [= [city] "Rome"] :flatp t) 116 | (mapcar 'winner *) 117 | 118 | ;; now we lose the CLOS objects and read the data "directly" 119 | (clsql:select [winner] [count [*]] 120 | :from [final] :group-by [winner]) 121 | 122 | ;; you can also transmit SQL statements as strings if you prefer 123 | (clsql:query "select distinct winner from final") 124 | 125 | ;; various looping constructs are available 126 | (clsql:do-query ((winner) [select [distinct [winner]] 127 | :from [final]]) 128 | (princ winner)) 129 | 130 | ;; and even a modified LOOP (which will work in /some/ Lisps) 131 | (loop for winner being the records 132 | of [select [winner] :from [final]] 133 | count (string= ":ITA" winner)) 134 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 135 | 136 | 137 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 138 | (defclass final (bknr.datastore:store-object) 139 | ((city :accessor city 140 | :initarg :city) 141 | (year :accessor year 142 | :initarg :year) 143 | (winner :accessor winner 144 | :initarg :winner)) 145 | (:metaclass bknr.datastore:persistent-class)) 146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | 148 | 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | (let ((object-subsystem 151 | (make-instance 'bknr.datastore:store-object-subsystem))) 152 | (make-instance 'bknr.datastore:mp-store 153 | :directory "/tmp/store/" 154 | :subsystems (list object-subsystem))) 155 | bknr.datastore:*store* 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | 158 | 159 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 160 | (loop for (city year winner) in '(("Rome" 1934 :ita) 161 | ("Paris" 1938 :ita) 162 | ("Bern" 1954 :deu) 163 | ("Stockholm" 1958 :bra)) 164 | for final = (make-instance 'final :city city 165 | :year year 166 | :winner winner) 167 | finally (return final)) 168 | ;; Oops, let's fix that... 169 | (bknr.datastore:with-transaction () 170 | (setf (city *) "Solna")) 171 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 172 | 173 | 174 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 175 | (bknr.datastore:store-objects-with-class 'final) 176 | (describe (first (last *))) 177 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 178 | 179 | 180 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 181 | (defclass final (bknr.datastore:store-object) 182 | ((city :accessor city 183 | :initarg :city) 184 | (year :accessor year 185 | :initarg :year 186 | :index-type bknr.indices:unique-index ;; added 187 | :index-reader final-by-year ;; added 188 | :index-values all-finals) ;; added 189 | (winner :accessor winner 190 | :initarg :winner)) 191 | (:metaclass bknr.datastore:persistent-class)) 192 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 193 | 194 | 195 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 196 | (final-by-year 1934) 197 | (length (all-finals)) 198 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 199 | 200 | 201 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 202 | (require :acache) 203 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 204 | 205 | 206 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 207 | (defclass final () 208 | ((city :accessor city 209 | :initarg :city) 210 | (year :accessor year 211 | :initarg :year 212 | :index :any-unique) 213 | (winner :accessor winner 214 | :initarg :winner)) 215 | (:metaclass db.ac:persistent-class)) 216 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 217 | 218 | 219 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 220 | (db.ac:open-file-database "/tmp/db/" 221 | :if-does-not-exist :create 222 | :if-exists :supersede) 223 | db.ac:*allegrocache* 224 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 225 | 226 | 227 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 228 | (loop for (city year winner) in '(("Rome" 1934 :ita) 229 | ("Paris" 1938 :ita) 230 | ("Bern" 1954 :deu) 231 | ("Stockholm" 1958 :bra)) 232 | for final = (make-instance 'final :city city 233 | :year year 234 | :winner winner) 235 | finally (return final)) 236 | ;; Oops, the same error again... 237 | (setf (city *) "Solna") 238 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 239 | 240 | 241 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 242 | (db.ac:commit) 243 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 244 | 245 | 246 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 247 | (db.ac:open-file-database "/tmp/db/") 248 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 249 | 250 | 251 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 252 | (db.ac:retrieve-from-index 'final 'year 1958) 253 | (describe *) 254 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 255 | -------------------------------------------------------------------------------- /code/chapter-16/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (defparameter *quux* 42) 13 | 14 | (defun foo (x) 15 | (let ((*quux* 23)) 16 | (bar (1- x) *quux*))) 17 | 18 | (defun bar (a b) 19 | (declare (optimize debug)) 20 | (let ((c (* b b))) 21 | (catch 'tag 22 | (baz c a)))) 23 | 24 | (defun baz (v w) 25 | (/ v w)) 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | (invoke-debugger 31 | (make-condition 'type-error :expected-type 'fixnum :datum 42.0)) 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | 34 | 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | (error 'type-error :expected-type 'fixnum :datum 42.0) 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | (let ((*break-on-signals* 'type-error)) 42 | (signal 'type-error :expected-type 'fixnum :datum 42.0)) 43 | 44 | (let ((*break-on-signals* 'arithmetic-error)) 45 | (ignore-errors 46 | (error 'division-by-zero :operands (list 42 0) :operation '/))) 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | 49 | 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | (catch 'tag 52 | (let ((*debugger-hook* 53 | (lambda (condition old-debugger-hook) 54 | (declare (ignore old-debugger-hook)) 55 | (format *error-output* 56 | "Condition ~S was suppressed.~%" condition) 57 | (throw 'tag 42)))) 58 | (error "Some error."))) 59 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | 61 | 62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | (block my-block 64 | (handler-bind ((error 65 | (lambda (condition) 66 | (return-from my-block 67 | (trivial-backtrace:print-backtrace condition 68 | :output nil))))) 69 | (foo 1))) 70 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 71 | 72 | 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | (defun female (n) 75 | (cond ((zerop n) 1) 76 | (t (- n (male (female (1- n))))))) 77 | 78 | (defun male (n) 79 | (cond ((zerop n) 0) 80 | (t (- n (female (male (1- n))))))) 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | 83 | 84 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 85 | (trace male) 86 | (male 3) 87 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 88 | 89 | 90 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 91 | ;; continued from above 92 | (trace female) 93 | (male 3) 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | 96 | 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | ;; continued from above 99 | (trace) ;; which functions are currently traced 100 | (untrace male) ;; stop tracing MALE 101 | (trace) ;; check again 102 | (untrace) ;; untrace ALL functions 103 | (trace) ;; check again 104 | (female 42) 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | 107 | 108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 109 | (defun foo (a) 110 | (declare (optimize debug)) 111 | (let* ((b (random 5)) 112 | (c (expt a b))) 113 | (- c a))) 114 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 115 | 116 | 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 118 | (step (foo 3)) 119 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 120 | 121 | 122 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 123 | (defvar foo 42 124 | "A variable with the same name as the function FOO.") 125 | 126 | (defun foo (x y) 127 | "Computes the BAR of X and Y and binds FOO." 128 | (let ((foo 23)) 129 | (bar x y))) 130 | 131 | (defun bar (a b) 132 | "Computes FLOOR after switching the arguments." 133 | (floor b a)) 134 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 135 | 136 | 137 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 138 | (documentation 'foo 'function) 139 | (documentation 'foo 'variable) 140 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 141 | 142 | 143 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 144 | (setf (logical-pathname-translations "SYS") 145 | '(("SYS:SRC;**;*.*.*" 146 | #p"/opt/sbcl-1.2.13/src/**/*.*") 147 | ("SYS:CONTRIB;**;*.*.*" 148 | #p"/opt/sbcl-1.2.13/contrib/**/*.*"))) 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | 151 | 152 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 153 | (describe (make-condition 'type-error 154 | :expected-type 'string 155 | :datum #\X)) 156 | (describe (let ((hash-table (make-hash-table))) 157 | (setf (gethash 42 hash-table) 23) 158 | hash-table)) 159 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 160 | 161 | 162 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 163 | (defparameter *thing* (vector :lp (list 20 "Hotels") 1971)) 164 | (inspect *thing*) 165 | *thing* 166 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 167 | 168 | 169 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 170 | (apropos "odd") 171 | (apropos :odd :cl) 172 | (apropos-list "odd" :cl) 173 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 174 | 175 | 176 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 177 | (ppcre:regex-apropos "lo.*lo.*la" :cl) 178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 179 | 180 | 181 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 182 | (defun my-add (x) (+ x x)) 183 | (fmakunbound 'my-add) 184 | (my-add 3) 185 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 186 | 187 | 188 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 189 | (defun my-add (x) (+ x x)) 190 | (defparameter my-add-fn #'my-add) 191 | (fmakunbound 'my-add) 192 | (funcall my-add-fn 21) 193 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 194 | 195 | 196 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 197 | (defvar *foo* 42) 198 | (makunbound '*foo*) 199 | *foo* 200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201 | 202 | 203 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 204 | (defmethod my-length ((x list)) 205 | (length x)) 206 | 207 | (defmethod my-length ((x symbol)) 208 | (length (symbol-name x))) 209 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 210 | 211 | 212 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 213 | (find-method #'my-length nil '(list)) 214 | (remove-method #'my-length *) 215 | (my-length 'foo) 216 | (my-length '(f o o)) 217 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 218 | 219 | 220 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 221 | (defclass my-class () 222 | ((a :initform 42 :reader a))) 223 | (defvar *a* (make-instance 'my-class)) 224 | (find-class 'my-class) 225 | (setf (find-class 'my-class) nil) 226 | (make-instance 'my-class) 227 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 228 | 229 | 230 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 231 | ;; continued from above 232 | *a* 233 | (class-of *) 234 | (a *a*) 235 | (make-instance **) 236 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 237 | 238 | 239 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 240 | (defvar *foo* 42) 241 | ;; (PROGN 242 | ;; (SYSTEM::UNPROCLAIM '(SPECIAL *FOO*)) 243 | ;; (MAKUNBOUND '*FOO*)) 244 | 245 | (defun my-add (x) (+ x x)) 246 | ;; (WHEN-LET (SYSTEM::REAL-SPEC (DSPEC:DSPEC-DEFINED-P '#'MY-ADD)) 247 | ;; (EVAL (DSPEC:DSPEC-UNDEFINER SYSTEM::REAL-SPEC))) 248 | 249 | (defmethod my-length ((x list)) 250 | (length x)) 251 | ;; (CLOS::UNDEFMETHOD MY-LENGTH (LIST)) 252 | 253 | (define-condition my-error (error) ()) 254 | ;; (CLOS::UNDEFCLASS MY-ERROR) 255 | 256 | (defclass my-class () 257 | ((a :initform 42 :reader a))) 258 | ;; (CLOS::UNDEFCLASS MY-CLASS) 259 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 260 | 261 | 262 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 263 | (defun foo (x) x) 264 | (trace foo) 265 | (with-output-to-string (*standard-output*) 266 | (with-input-from-string (*standard-input* (format nil "n~%")) 267 | (print (y-or-n-p "Do You Like My New Car?")) 268 | (foo 42) 269 | (warn "Achtung!") 270 | (print (read)))) 271 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 272 | 273 | 274 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 | (list *standard-output* *standard-input*) 276 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 277 | 278 | 279 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 280 | (floor 42 4) 281 | :foo 282 | (parse-integer "42 ") 283 | (list * ** *** / // /// + ++ +++ -) 284 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 285 | 286 | 287 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 288 | -3/4 289 | (* 5 *) 290 | (* ** **) 291 | (+ * ** -3) 292 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 293 | 294 | 295 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 296 | (handler-case 297 | (delete-file "/tmp/my-dribble") 298 | (file-error ())) 299 | (dribble "/tmp/my-dribble") 300 | (+ 40 2) 301 | (print *) 302 | (dribble) 303 | (with-open-file (in "/tmp/my-dribble") 304 | (loop for line = (read-line in nil) 305 | while line 306 | do (format t "DRIBBLE: ~A~%" line))) 307 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 308 | -------------------------------------------------------------------------------- /code/chapter-08/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (with-input-from-string (in "(#\\a \"foo\" #c(3 4) 4/5)") 13 | (read in)) 14 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | 16 | 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | (read-from-string "(nIL .3141d1 #.(print 42) foo)") 19 | (intern "FOO") 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | 22 | 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | (let ((input "84/2 #c(23 0)")) 25 | (multiple-value-bind (part-1 position) 26 | (read-from-string input) 27 | (list part-1 28 | (read-from-string input t nil :start position)))) 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | (read-from-string "(+ 40 2)") 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | 36 | 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | (eval (read-from-string "(+ 40 2)")) 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | 41 | 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | (defun count-1-2-3 (list) 44 | (let ((counters '(:one 0 :two 0 :three 0))) 45 | (dolist (item list) 46 | (incf (getf counters item))) 47 | counters)) 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | 50 | 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | (count-1-2-3 (list :one :three :three :one :one :one)) 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | 55 | 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | (count-1-2-3 (list :two :two)) 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | 60 | 61 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | (defun oldest-marx-brother () "Chico") 63 | (setf (subseq (oldest-marx-brother) 0 4) "Harp") 64 | ;; what follows is technically undefined behavior! 65 | (oldest-marx-brother) 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | 68 | 69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 | (defun area (radius) 71 | (* 3.141592653589793D0 72 | radius radius)) 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | 75 | 76 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 77 | (defun area (radius) 78 | (* (* 4 (atan 1d0)) 79 | radius radius)) 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | 82 | 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | (defun area (radius) 85 | (* #.(* 4 (atan 1d0)) 86 | radius radius)) 87 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 88 | 89 | 90 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 91 | #.(let ((h (make-hash-table))) 92 | (setf (gethash 42 h) t) 93 | h) 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | 96 | 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | (defun compute-pi () 99 | (* 4 (atan 1d0))) 100 | (defun area (radius) 101 | (* #.(compute-pi) radius radius)) 102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 | 104 | 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | (defun banner () 107 | (format t "Version 4.2. Compiled at Lisp universal time ~A.~%" 108 | #.(get-universal-time))) 109 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 110 | 111 | 112 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 113 | (defparameter *a* #(1 2 4 8 16)) 114 | (aref *a* 3) 115 | *a* 116 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 | 118 | 119 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 120 | (defparameter *a* #2A((1 2 4 8) (1 3 9 27))) 121 | (aref *a* 1 3) 122 | *a* 123 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 | 125 | 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | #4(1 2 3) 128 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | 130 | 131 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 132 | #2A((1 2 4 8) (1 3 9 27)) 133 | (aref * 1 1) 134 | #1A((1 2 4 8) (1 3 9 27)) 135 | (aref * 1) 136 | #0A((1 2 4 8) (1 3 9 27)) 137 | (aref *) 138 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 | 140 | 141 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 142 | (defun foo (x) (+ x 42)) 143 | (flet ((foo (x) (1+ x))) 144 | (list (funcall 'foo 0) (funcall #'foo 0))) 145 | (funcall #'foo 0) 146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | 148 | 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | (+ #1=21 #1#) 151 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 152 | 153 | 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | (defun foo () 156 | (let ((a (list #2='foo)) 157 | (b (list #2# #2#))) 158 | (append a b))) 159 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 160 | 161 | 162 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 163 | (defun bar () 164 | (list #2# 'bar)) 165 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 166 | 167 | 168 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 169 | (let ((a '#1=(10 . #1#))) 170 | (nth 42 a)) 171 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 172 | 173 | 174 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 175 | (let ((a '(1 2 3)) 176 | (b '(1 2 3))) 177 | (list (equal a b) (eq a b))) 178 | (let ((a #1='(1 2 3)) 179 | (b #1#)) 180 | (list (equal a b) (eq a b))) 181 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 182 | 183 | 184 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 185 | (setf *readtable* (copy-readtable)) 186 | ;; now change the current readtable 187 | ;; and afterward enter forms to try out your new syntax 188 | (setf *readtable* (copy-readtable nil)) 189 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 190 | 191 | 192 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 193 | (with-input-from-string (in "10 10") 194 | (let ((*read-base* 16)) 195 | (list (read in) 196 | (with-standard-io-syntax 197 | (read in))))) 198 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 199 | 200 | 201 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 202 | 'ab$c 203 | (set-syntax-from-char #\$ #\;) 204 | 'ab$c 205 | (setf *readtable* (copy-readtable nil)) 206 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 207 | 208 | 209 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 210 | (set-syntax-from-char #\$ #\\) 211 | 'a\$b$\c 212 | (setf *readtable* (copy-readtable nil)) 213 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 214 | 215 | 216 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 217 | (set-syntax-from-char #\$ #\|) 218 | 'a$"()$c 219 | 'a|"()$c 220 | (setf *readtable* (copy-readtable nil)) 221 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 222 | 223 | 224 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 225 | (defun brace-reader (stream char) 226 | (declare (ignore char)) 227 | (let ((hash (make-hash-table))) 228 | (loop for (key value) 229 | on (read-delimited-list #\} stream t) 230 | by #'cddr 231 | do (setf (gethash key hash) value)) 232 | hash)) 233 | (set-macro-character #\{ 'brace-reader) 234 | (set-macro-character #\} (get-macro-character #\) nil)) 235 | {:two 2 :five 5} 236 | (gethash :five *) 237 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 238 | 239 | 240 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 241 | (set-syntax-from-char #\! #\") 242 | !Hello World! 243 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 244 | 245 | 246 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 247 | {:two 2 :inner-hash {:one 1 :foo 'foo}} 248 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 249 | 250 | 251 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 252 | {:two 2 :five 5 } 253 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 254 | 255 | 256 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 257 | {:two 2 :five 5} 258 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 259 | 260 | 261 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 262 | (defvar *string-reader* 263 | (get-macro-character #\" nil)) 264 | (set-dispatch-macro-character 265 | #\# #\? 266 | (lambda (stream sub-char infix) 267 | (let ((string 268 | (funcall *string-reader* stream sub-char))) 269 | (cond (infix (remove (code-char infix) string)) 270 | (t string))))) 271 | #?abc? 272 | (char-code #\a) 273 | #97?abcacba? 274 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 | 276 | 277 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 278 | (make-dispatch-macro-character #\!) 279 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 280 | 281 | 282 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 283 | (with-input-from-string (in "42 23") 284 | (read in) ;; <-- 285 | (list (read-char in) 286 | (read-char in))) 287 | (with-input-from-string (in "42 23") 288 | (read-preserving-whitespace in) ;; <-- 289 | (list (read-char in) 290 | (read-char in))) 291 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 292 | 293 | 294 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 295 | (read-from-string "424242 ") 296 | (read-from-string "424242 " t nil :preserve-whitespace t) 297 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 298 | -------------------------------------------------------------------------------- /code/chapter-04/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | ;; see 13 | (defun fermat (n) (1+ (expt 2 (expt 2 n)))) 14 | (fermat 7) 15 | (fermat 8) 16 | (gcd * **) 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | (loop for n in (list most-positive-fixnum 22 | (1+ most-positive-fixnum)) 23 | append (loop for type in '(fixnum bignum integer) 24 | collect (typep n type))) 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | (1+ (max (integer-length most-positive-fixnum) 30 | (integer-length most-negative-fixnum))) 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | (mod (* 58 74051161) (expt 2 32)) 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | (defconstant +mod+ (expt 2 32)) 41 | (defun plus (x y) (mod (+ x y) +mod+)) 42 | (defun times (x y) (mod (* x y) +mod+)) 43 | ;; etc. 44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | 46 | 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | (defconstant +mod+ (expt 2 32)) 49 | (defun times-mod (x y) (mod (* x y) +mod+)) 50 | (defun times-rem (x y) (rem (* x y) +mod+)) 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | 53 | 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | (defun times-mod (x y) 56 | (declare (type (unsigned-byte 32) x y)) 57 | (mod (* x y) (expt 2 32))) 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | 60 | 61 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | (list (list #b101010 #o52 #x2A) 63 | (loop for fmt in '("~B" "~O" "~X") 64 | collect (format nil fmt 42))) 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | 67 | 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 | (loop for fmt in '("~R" "~:R" "~@R") 70 | collect (format nil fmt 42)) 71 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | 73 | 74 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 75 | ;; the default values 76 | *read-base* 77 | *print-base* 78 | ;; switch to binary input 79 | (setf *read-base* 2) 80 | 101010 81 | ;; you can still override this with # 82 | #x2A 83 | ;; this does NOT switch back to decimal because "10" is read 84 | ;; as a binary number... 85 | (setf *read-base* 10) 86 | ;; this works 87 | (setf *read-base* 1010) 88 | ;; now switch to hexadecimal output 89 | (setf *print-base* 16) 90 | 42 91 | (setf *print-radix* t) 92 | 42 93 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 94 | 95 | 96 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 97 | (/ 3 4) 98 | (floor 3 4) 99 | 6/8 100 | (* 3/4 8/3) 101 | (+ 1/3 3/7) 102 | (/ (expt 2 30) (1+ (expt 3 30))) 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | 105 | 106 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 107 | (denominator (/ 2 -10)) 108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 109 | 110 | 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | (/ 3 4) 113 | (floor (/ 3 4)) 114 | (floor 3 4) 115 | (floor -3 4) 116 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 | 118 | 119 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 120 | (dolist (fn '(floor ceiling truncate round)) 121 | (dolist (args '((3 4) (-3 4))) 122 | (format t "~A -> ~A " (list* fn args) (apply fn args))) 123 | (terpri)) 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | 126 | 127 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 128 | (loop for i in '(1/2 3/2 5/2 7/2) 129 | collect (round i)) 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | 132 | 133 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 134 | (rational 0.5) 135 | (rationalize 0.5) 136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 137 | 138 | 139 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 | (rational 0.2) 141 | (rationalize 0.2) 142 | (list (float *) (float **)) 143 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 144 | 145 | 146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | (float 1/7) 148 | (float 1/7 1d0) 149 | (float 0.1f0 1d0) 150 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 151 | 152 | 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | (* 2f0 2d0) 155 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | 157 | 158 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | (* 2 2d0) 160 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 161 | 162 | 163 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 164 | (< 6/7 (float 6/7)) 165 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 166 | 167 | 168 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 169 | *read-default-float-format* 170 | (- 1.00000001 1) 171 | 1.00000001 172 | (- 1.00000001d0 1) 173 | (setf *read-default-float-format* 'double-float) 174 | (- 1.00000001 1) 175 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 176 | 177 | 178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 179 | *read-default-float-format* 180 | 1.0f0 181 | 1.0d0 182 | (setf *read-default-float-format* 'double-float) 183 | 1.0f0 184 | 1.0d0 185 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 186 | 187 | 188 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 189 | (defun foo (orig &optional (n 10)) 190 | (let ((x orig)) 191 | (loop repeat n do (setf x (sqrt x))) 192 | (loop repeat n do (setf x (* x x))) 193 | (list x (* (/ (abs (- x orig)) orig) 100)))) 194 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 195 | 196 | 197 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 198 | (setf (ext:long-float-digits) 256) 199 | (foo 2l0 50) 200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201 | 202 | 203 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 204 | (defun foo-r (orig &optional (n 10)) 205 | (let ((x orig)) 206 | (loop repeat n do (setf x (cr:sqrt-r x))) 207 | (loop repeat n do (setf x (cr:*r x x))) 208 | x)) 209 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 210 | 211 | 212 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 213 | (cr:sqrt-r 2) 214 | (cr:print-r * 30) 215 | (cr:print-r ** 40) 216 | (cr:print-r *** 50) 217 | ;; and so on... 218 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 219 | 220 | 221 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 222 | (sqrt -1) 223 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 224 | 225 | 226 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 227 | #C(8 -9) 228 | #c(2/4 1/2) 229 | #c(2/4 .5) 230 | #c(2d0 2f0) 231 | (complex 1/2 3) 232 | (complex 1 0) 233 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 234 | 235 | 236 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 237 | (* #c(2.0 3.0) #c(-1.0 2.0)) 238 | (sin #c(2.0d0 3.0)) 239 | (abs #c(3 -4)) 240 | (+ #c(61/2 3) #c(23/2 -3)) 241 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 242 | 243 | 244 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 245 | (1+ (exp (* pi #c(0 1)))) 246 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 247 | 248 | 249 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 250 | (parse-integer " 42") 251 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 252 | 253 | 254 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 255 | (parse-integer "42 quux") 256 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 257 | 258 | 259 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 260 | (parse-integer "42 quux" :junk-allowed t) 261 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 262 | 263 | 264 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 265 | (defun parse-integers (string) 266 | (let ((start 0) 267 | (end (length string)) 268 | (result '())) 269 | (loop 270 | (when (>= start end) 271 | (return (nreverse result))) 272 | (multiple-value-bind (number pos) 273 | (parse-integer string :start start :junk-allowed t) 274 | (cond (number 275 | (push number result) 276 | (setf start pos)) 277 | (t (setf start end))))))) 278 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 279 | 280 | 281 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 282 | (loop for radix in '(2 8 10 16) 283 | collect (parse-integer "111" :radix radix)) 284 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 285 | 286 | 287 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 288 | (read-from-string "#.(lw:quit)") 289 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 290 | 291 | 292 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 293 | (loop for input in '("-42" "2/84" "#c(3 4)" "2.34" "2d3") 294 | collect (parse-number:parse-number input)) 295 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 296 | 297 | 298 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 299 | 1.1234567890123456D0 300 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 301 | 302 | 303 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 304 | (= 42 42.0) 305 | (eql 42 42.0) 306 | (= 0.33333333 1/3) 307 | (= 0.33333333 11184811/33554432) 308 | (eql 0.33333333 11184811/33554432) 309 | (= #c(3 0) 3) 310 | (eql #c(3 0) 3) 311 | (= #c(3.0 0) 3) 312 | (eql #c(3.0 0) 3) 313 | (= (1+ most-positive-fixnum) (1+ most-positive-fixnum)) 314 | (eql (1+ most-positive-fixnum) (1+ most-positive-fixnum)) 315 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 316 | 317 | 318 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 319 | (eq (1+ most-positive-fixnum) (1+ most-positive-fixnum)) 320 | (eq 3d0 3d0) 321 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 322 | 323 | 324 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 325 | (dolist (x '(1 -1)) 326 | (dolist (y '(1 -1)) 327 | (print (list x y 328 | (round (* (/ 180 pi) (atan (/ y x)))) 329 | (round (* (/ 180 pi) (atan y x))))))) 330 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 331 | -------------------------------------------------------------------------------- /code/chapter-22/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (sb-posix:getenv "HOME") 13 | (sb-posix:setenv "WAKA" "Jawaka" 1) 14 | (sb-posix:getenv "WAKA") 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | (ccl:getenv "HOME") 20 | (ccl:setenv "WAKA" "Jawaka") 21 | (ccl:getenv "WAKA") 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | (ext:getenv "HOME") 27 | (setf (ext:getenv "WAKA") "Jawaka") 28 | (ext:getenv "WAKA") 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | (length (win32:collect-registry-subkeys 34 | "Hardware\\Description\\System\\CentralProcessor" 35 | :root :local-machine)) 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | (defun test () 41 | (list (short-site-name) 42 | (long-site-name) 43 | (lisp-implementation-type) 44 | (lisp-implementation-version) 45 | (machine-instance) 46 | (machine-type) 47 | (machine-version) 48 | (software-type) 49 | (software-version))) 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | 52 | 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | (defun hello () 55 | (format t "Hello World!~%The time is ~A.~%" (get-universal-time))) 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | 58 | 59 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | (sb-ext:save-lisp-and-die #p"foo.exe" :toplevel #'hello 61 | :executable t) 62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | 64 | 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | (ccl:save-application #p"foo.exe" :toplevel-function #'hello 67 | :prepend-kernel t) 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 | 70 | 71 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | (ext:saveinitmem #p"foo.exe" :init-function (lambda () 73 | (hello) 74 | (ext:quit)) 75 | :executable t 76 | :quiet t :norc t) 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | 79 | 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | (compile-file "/tmp/hello.lisp" :system-p t) 82 | (c:build-program #p"foo.exe" :lisp-files '(#p"/tmp/hello.o") 83 | :epilogue-code '(hello)) 84 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 85 | 86 | 87 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 88 | (sb-ext:save-lisp-and-die #p"/tmp/my-image") 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | 91 | 92 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 93 | (external-program:run "date" nil) 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | 96 | 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | (external-program:run "date" nil :output *standard-output*) 99 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 100 | 101 | 102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 | (external-program:run "date" '("-u") 104 | :output *standard-output*) 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | 107 | 108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 109 | (with-output-to-string (out) 110 | (external-program:run "date" '("-R") :output out)) 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | 113 | 114 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 115 | (with-input-from-string (in (format nil "One~%Two~%Three~%")) 116 | (external-program:run "wc" '("-l") 117 | :output *standard-output* 118 | :input in)) 119 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 120 | 121 | 122 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 123 | ;; see file "filter.c" in this directory 124 | (external-program:start "/tmp/foo" nil 125 | :input :stream :output :stream) 126 | (defparameter *p* *) 127 | (defparameter *in* 128 | (external-program:process-input-stream *p*)) 129 | (defparameter *out* 130 | (external-program:process-output-stream *p*)) 131 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 132 | 133 | 134 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 135 | ;; continued from above 136 | (format *in* "addressee~%") 137 | (finish-output *in*) 138 | (read-line *out*) 139 | (format *in* "committee~%") 140 | (format *in* "mississippi~%") 141 | (finish-output *in*) 142 | (list (read-line *out*) (read-line *out*)) 143 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 144 | 145 | 146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | ;; continued from above 148 | (external-program:process-status *p*) 149 | (close *in*) 150 | (external-program:process-status *p*) 151 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 152 | 153 | 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | (with-open-stream (stream (sys:open-pipe "/tmp/foo" :direction :io)) 156 | (format stream "mississippi~%") 157 | (finish-output stream) 158 | (read-line stream)) 159 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 160 | 161 | 162 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 163 | ;; see Lisp and C files in this directory 164 | (compile-file "/tmp/hello.lisp" :system-p t) 165 | (c:build-shared-library #p"/tmp/hello.so" 166 | :lisp-files '(#p"/tmp/hello.o") 167 | :init-name "init_mylib") 168 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 169 | 170 | 171 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 172 | ;; see Lisp and C files in this directory 173 | (fli:define-foreign-callable ("toLispTime" :result-type :long) 174 | ((year :int) 175 | (month :int) 176 | (date :int)) 177 | (encode-universal-time 0 0 0 date month year)) 178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 179 | 180 | 181 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 182 | (defun time-test () 183 | (let ((run-time (get-internal-run-time)) 184 | (real-time (get-internal-real-time))) 185 | (sleep 2.5) 186 | (format t "Run time: ~,6F seconds~%Real time: ~,6F seconds~%" 187 | (/ (- (get-internal-run-time) run-time) 188 | internal-time-units-per-second) 189 | (/ (- (get-internal-real-time) real-time) 190 | internal-time-units-per-second)))) 191 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 192 | 193 | 194 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 195 | (time-test) 196 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 197 | 198 | 199 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 200 | (get-decoded-time) 201 | (get-universal-time) 202 | (decode-universal-time *) 203 | (multiple-value-bind 204 | (second minute hour date month year day daylight-p zone) 205 | (decode-universal-time **) 206 | (declare (ignore day daylight-p zone)) 207 | (encode-universal-time second minute hour date month year)) 208 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 209 | 210 | 211 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 212 | (encode-universal-time 0 0 0 4 12 1993) 213 | (encode-universal-time 0 0 0 4 12 93) 214 | (encode-universal-time 0 0 0 21 12 1940) 215 | (encode-universal-time 0 0 0 21 12 40) 216 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 217 | 218 | 219 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 220 | (nth-value 8 (get-decoded-time)) 221 | (nth-value 7 (get-decoded-time)) 222 | (encode-universal-time 0 10 17 24 8 2015) 223 | (encode-universal-time 0 10 17 24 8 2015 -2) 224 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 225 | 226 | 227 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 228 | (local-time:now) 229 | (local-time:encode-timestamp 123456789 0 10 12 23 12 1965) 230 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 231 | 232 | 233 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 234 | (local-time:parse-timestring "1965-12-23") 235 | (local-time:parse-timestring "1965-12-23T12:20:12") 236 | (local-time:parse-timestring "1965-12-23T12:20:12-05") 237 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 238 | 239 | 240 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 241 | (local-time:reread-timezone-repository) 242 | (local-time:timestamp-subtimezone 243 | (local-time:encode-timestamp 0 0 40 18 24 8 2015) 244 | (local-time:find-timezone-by-location-name "Europe/Moscow")) 245 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 246 | 247 | 248 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 249 | (defparameter *timestamp* 250 | (local-time:encode-timestamp 0 13 5 19 24 8 2015)) 251 | (local-time:format-timestring nil *timestamp*) 252 | (local-time:format-timestring 253 | nil *timestamp* 254 | :format local-time:+rfc-1123-format+) 255 | (local-time:format-timestring 256 | nil *timestamp* :format 257 | '(:long-weekday ", " :day " " :long-month)) 258 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 259 | 260 | 261 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 262 | (local-time:enable-read-macros) 263 | @2015-08-24T19:05:13 264 | (local-time:timestamp< @2015-08-24T19:05:13 265 | @2015-07-14T20:00:33) 266 | (local-time:timestamp+ @2015-08-24T19:05:13 10 :day) 267 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 268 | 269 | 270 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 271 | (room) 272 | (trivial-garbage:gc) 273 | (room) 274 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 | 276 | 277 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 278 | (defparameter *resources* (loop for i below 10 279 | collect i)) 280 | *resources* 281 | (defclass foo () 282 | ((resource :initform (pop *resources*)))) 283 | (defparameter *objects* (loop repeat 5 284 | collect (make-instance 'foo))) 285 | *resources* 286 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 287 | 288 | 289 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 290 | ;; continued from above 291 | (dolist (object *objects*) 292 | (trivial-garbage:finalize 293 | object 294 | (let ((resource (slot-value object 'resource))) 295 | (lambda () 296 | (push resource *resources*))))) 297 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 298 | 299 | 300 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 301 | ;; continued from above 302 | (setq *objects* (cdr *objects*)) 303 | *resources* 304 | (trivial-garbage:gc :full t) 305 | *resources* 306 | (setq *objects* nil) 307 | (trivial-garbage:gc :full t) 308 | *resources* 309 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 310 | -------------------------------------------------------------------------------- /code/chapter-03/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (char-code #\a) 13 | (char-code #\A) 14 | (char-code #\ü) 15 | (char-code #\א) 16 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | 18 | 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | (code-char 97) 21 | (code-char 65) 22 | (code-char 252) 23 | (code-char 1488) 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | (char-name #\A) 29 | (char-name #\a) 30 | (name-char "Latin_Small_Letter_A") 31 | #\latin_small_letter_a 32 | (char-name (code-char 1488)) 33 | #\HEBREW_LETTER_ALEF 34 | #\U+05D0 35 | (name-char "U+05D0") 36 | (name-char "A") 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | (with-open-file (out "/tmp/foo.txt" 42 | :direction :output 43 | :if-exists :supersede 44 | :element-type '(unsigned-byte 8)) 45 | (write-byte 195 out) 46 | (write-byte 156 out)) 47 | (with-open-file (out "/tmp/foo.txt" 48 | :direction :output 49 | :if-exists :append 50 | :element-type 'character 51 | :external-format :latin-1) 52 | (write-string "berjazz" out)) 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | 55 | 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | (with-open-file (in "/tmp/foo.txt" 58 | :element-type 'character 59 | :external-format :utf-8) 60 | (read-line in)) 61 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | 63 | 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | (char= #\a #\a) 66 | (char= #\a #\b) 67 | (char= #\a #\A) 68 | (char-equal #\a #\A) 69 | (char< #\a #\b) 70 | (char< #\A #\b) 71 | (char< #\a #\B) 72 | (char-lessp #\A #\b) 73 | (char-lessp #\a #\B) 74 | (eql "foo" "foo") 75 | (string= "foo" "foo") 76 | (equal "foo" "foo") 77 | (string= "foo" "Foo") 78 | (equal "foo" "Foo") 79 | (string-equal "foo" "Foo") 80 | (equalp "foo" "Foo") 81 | (string< "adam" "eve") 82 | (string< "aardvark" "aardwolf") 83 | (string< "werewolf" "aardwolf") 84 | (string< "aardvark" "Aardwolf") 85 | (string-lessp "aardvark" "Aardwolf") 86 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 87 | 88 | 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | (both-case-p (code-char #x17F)) 91 | (char-equal #\S (code-char #x17F)) 92 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 93 | 94 | 95 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 96 | (format nil "~Cberjazz" #\U+00DC) 97 | (let ((foo "Ü")) 98 | (format nil "~Aberjazz" foo)) 99 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 100 | 101 | 102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 | (format nil "~Cberjazz" #\U+00DC) 104 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 | 106 | 107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 | #.(format nil "~Cberjazz" #\U+00DC) 109 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 110 | 111 | 112 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 113 | (char-upcase #\a) 114 | (char-downcase #\A) 115 | (char-downcase #\a) 116 | (char-downcase #\Space) 117 | (char-downcase #\greek_capital_letter_alpha) 118 | (upper-case-p #\A) 119 | (lower-case-p #\a) 120 | (upper-case-p #\Space) 121 | (lower-case-p #\Space) 122 | (both-case-p #\Space) 123 | (both-case-p #\hebrew_letter_alef) 124 | (string-upcase "miles davis") 125 | (string-downcase "MILES") 126 | (string-capitalize "miles DAVIS") 127 | (string-upcase "miles davis" :start 0 :end 6) 128 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | 130 | 131 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 132 | (let ((string (copy-seq "Grover Washington, jr."))) 133 | (setf (char string 19) 134 | (char-upcase (char string 19))) 135 | string) 136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 137 | 138 | 139 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 | (format nil "Downcase: ~(~A~)" "FOO") 141 | (format nil "Capitalize: ~:(~A~)" "FOO BAR BAZ") 142 | (format nil "Capitalize first word, downcase rest: ~@(~A~)" 143 | "FOO BAR BAZ") 144 | (format nil "Upcase: ~:@(~A~)" "Foo BAR baz") 145 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 146 | 147 | 148 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 149 | (subseq "Cookbook" 4) 150 | (subseq "Cookbook" 4 7) 151 | (let ((string1 (copy-seq "Harpo Marx")) 152 | (string2 (copy-seq "Groucho, Harpo, and Chico"))) 153 | (setf (subseq string1 0 5) "Zeppo") 154 | (print string1) 155 | (setf (subseq string1 0 5) "Groucho") 156 | (print string1) 157 | (setf string1 158 | (replace string1 string2 159 | :start1 0 :end1 5 160 | :start2 9 :end2 14)) 161 | (print string1) 162 | (setf (subseq string1 0) "Groucho") 163 | string1) 164 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 165 | 166 | 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | (let* ((string1 (copy-seq "walk")) 169 | (string2 (subseq string1 0))) 170 | (setf (char string2 0) #\t) 171 | (values string1 string2)) 172 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 173 | 174 | 175 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 176 | (find #\o "We're Only In It For The Money") 177 | (find #\o "We're Only In It For The Money" 178 | :test 'char-equal) 179 | (position #\o "We're Only In It For The Money") 180 | (position #\O "We're Only In It For The Money") 181 | (search "on" "We're Only In It For The Money") 182 | (search "on" "We're Only In It For The Money" 183 | :test 'char-equal) 184 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 185 | 186 | 187 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 188 | (string-trim '(#\Space #\Linefeed) " 189 | This is a sentence. ") 190 | (string-left-trim "([" "([foo])") 191 | (string-right-trim ")]" *) 192 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 193 | 194 | 195 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 196 | (let* ((string1 (copy-seq "abc")) 197 | (string2 (string-trim "x" string1))) 198 | (setf (char string2 0) #\A) 199 | (list string1 string2)) 200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201 | 202 | 203 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 204 | ;; assumes something like ASCII - see footnote 205 | ;; see https://en.wikipedia.org/wiki/Digital_root 206 | (defun digital-root (string) 207 | (assert (every #'digit-char-p string) 208 | (string) 209 | "~S doesn't denote a non-negative decimal integer." 210 | string) 211 | (loop for char across string 212 | sum (digit-char-p char) into result 213 | finally (return 214 | (if (> result 9) 215 | (digital-root (princ-to-string result)) 216 | result)))) 217 | (digital-root "12") 218 | (digital-root "1234") 219 | ;; assumes something like ASCII - see footnote 220 | ;; see https://en.wikipedia.org/wiki/ROT13 221 | (defun rot13-char (char) 222 | (cond ((char<= #\a char #\z) 223 | (code-char (+ (mod (+ (- (char-code char) (char-code #\a)) 224 | 13) 225 | 26) 226 | (char-code #\a)))) 227 | ((char<= #\A char #\Z) 228 | (code-char (+ (mod (+ (- (char-code char) (char-code #\A)) 229 | 13) 230 | 26) 231 | (char-code #\A)))))) 232 | (map 'string #'rot13-char "foobar") 233 | (map 'string #'rot13-char *) 234 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 235 | 236 | 237 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 238 | (let ((string "frob")) 239 | (values (aref string 0) 240 | (char string 1) 241 | (schar string 2) 242 | (subseq string 3 4))) 243 | (let ((string "baz")) 244 | (loop for i below (length string) 245 | collect (char string i))) 246 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 247 | 248 | 249 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 250 | (coerce "Recipes" 'list) 251 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 252 | 253 | 254 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 255 | (defun n-rot13-string (string) 256 | (loop for i below (length string) 257 | do (setf (char string i) 258 | (rot13-char (char string i))))) 259 | (defparameter *string* (copy-seq "foobar")) 260 | (n-rot13-string *string*) 261 | *string* 262 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 263 | 264 | 265 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 266 | ;; or like this: 267 | (defun n-rot13-string (string) 268 | (map-into string 'rot13-char string)) 269 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 270 | 271 | 272 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 273 | (defun join (separator list) 274 | (with-output-to-string (out) 275 | (loop for (element . more) on list 276 | do (princ element out) 277 | when more 278 | do (princ separator out)))) 279 | (join #\Space '("This" "is" "it")) 280 | (join #\- '(2003 12 31)) 281 | (join ", " '("C" "C++" "C#")) 282 | (join "" '("Hallo" "ween")) 283 | (join #\- '()) 284 | (join #\- '("One item only")) 285 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 286 | 287 | 288 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 289 | (defun join (separator list) 290 | (with-output-to-string (out) 291 | (loop (princ (or (pop list) "") out) 292 | (unless list (return)) 293 | (princ separator out)))) 294 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 295 | 296 | 297 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 298 | (defun join (separator list) 299 | (with-output-to-string (out) 300 | (when list 301 | (princ (pop list) out)) 302 | (loop (unless list (return)) 303 | (princ separator out) 304 | (princ (pop list) out)))) 305 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 306 | 307 | 308 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 309 | (format nil "~{~A~^, ~}" (list "C" "C++" "C#")) 310 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 311 | 312 | 313 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 314 | (defun list-join (separator list) 315 | (loop for (element . more) on list 316 | collect element 317 | when more 318 | collect separator)) 319 | (list-join '+ (loop for i below 5 collect i)) 320 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 321 | 322 | 323 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 324 | (defparameter *csv-readtable* (copy-readtable)) 325 | (set-syntax-from-char #\, #\Space *csv-readtable*) 326 | (defun read-csv-line (string) 327 | (let ((*readtable* *csv-readtable*)) 328 | (with-input-from-string (stream string) 329 | (loop for object = (read stream nil nil) 330 | while object 331 | collect object)))) 332 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 333 | 334 | 335 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 336 | ;; see separate file "test.tsv" in this directory 337 | (with-open-file (stream "/tmp/test.csv") 338 | (loop for line = (read-line stream nil nil) 339 | while line 340 | collect (read-csv-line line))) 341 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 342 | -------------------------------------------------------------------------------- /code/chapter-01/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (defpackage :p1 13 | (:intern :alpha) 14 | (:use :cl) 15 | (:export :bravo :charlie)) 16 | 17 | (defpackage :p2 18 | (:intern :alpha :delta) 19 | (:use :p1) 20 | (:export :bravo :echo)) 21 | 22 | (defpackage :p3 23 | (:intern :alpha) 24 | (:use :p2 :cl) 25 | (:export :charlie) 26 | (:import-from :p2 :delta)) 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | (import 'p2::alpha :p3) 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | 34 | 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | (defmacro swap (var-1 var-2) 37 | `(let ((temp ,var-1)) 38 | (setf ,var-1 ,var-2 39 | ,var-2 temp) 40 | (values))) 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | 43 | 44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | (defparameter *a* 42) 46 | (defparameter *b* 23) 47 | (swap *a* *b*) 48 | (list *a* *b*) 49 | (defparameter temp 100) 50 | (swap temp *a*) 51 | (list temp *a*) 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | 54 | 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | (let ((temp temp)) 57 | (setf temp *a* 58 | *a* temp) 59 | (values)) 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | 62 | 63 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 64 | (defmacro swap (var-1 var-2) 65 | `(let ((my-own-temp-var-name-please-do-not-use ,var-1)) 66 | (setf ,var-1 ,var-2 67 | ,var-2 my-own-temp-var-name-please-do-not-use) 68 | (values))) 69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 | 71 | 72 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 73 | (defmacro swap (var-1 var-2) 74 | (let ((temp-var (gensym))) ;; <- added 75 | `(let ((,temp-var ,var-1)) ;; <- changed 76 | (setf ,var-1 ,var-2 77 | ,var-2 ,temp-var) ;; <- changed 78 | (values)))) 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | 81 | 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | (macroexpand '(swap *a* *b*)) 84 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 85 | 86 | 87 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 88 | (make-symbol "FOO") 89 | (make-symbol "FOO") 90 | (eql * **) 91 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 92 | 93 | 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | (defmacro swap (var-1 var-2) 96 | `(let ((#:temp ,var-1)) 97 | (setf ,var-1 ,var-2 98 | ,var-2 #:temp) 99 | (values))) 100 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 101 | 102 | 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | (defmacro swap (var-1 var-2) 105 | (let ((temp '#:temp)) 106 | `(let ((,temp ,var-1)) 107 | (setf ,var-1 ,var-2 108 | ,var-2 ,temp) 109 | (values)))) 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | 112 | 113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 114 | (defun test () 42) 115 | (defparameter *s* 'test) ;; or (DEFPARAMETER *S* *) instead 116 | (test) 117 | (unintern 'test) 118 | (test) 119 | (funcall *s*) ;; or (#.*s*) instead 120 | *s* 121 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 122 | 123 | 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | (eval-when (:execute) 42) 126 | (unintern :execute :keyword) 127 | (eval-when (:execute) 42) 128 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | 130 | 131 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 132 | (setf (symbol-function 'test) (symbol-function *s*)) 133 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 134 | 135 | 136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 137 | (unintern 'test) 138 | (import *s*) 139 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 | 141 | 142 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 | (defpackage :bio 144 | (:use :cl)) 145 | (in-package :bio) 146 | (defclass tree () ()) 147 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 148 | 149 | 150 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 151 | (defpackage :graph 152 | (:use :cl) 153 | (:export :vertex :edge :tree)) 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | 156 | 157 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 158 | (use-package :graph) 159 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 160 | 161 | 162 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 163 | (shadow 'tree) 164 | (use-package :graph) 165 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 166 | 167 | 168 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 169 | (defpackage :bio 170 | (:use :cl)) 171 | (in-package :bio) 172 | (defclass tree () ()) 173 | (find-class 'tree nil) 174 | (defpackage :graph 175 | (:use :cl) 176 | (:export :vertex :edge :tree)) 177 | (shadowing-import 'graph:tree) 178 | (use-package :graph) 179 | (find-class 'tree nil) 180 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 181 | 182 | 183 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 184 | (defpackage :graph 185 | (:export :node :vertex :tree)) 186 | (defpackage :bio 187 | (:export :cat :dog :tree)) 188 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 189 | 190 | 191 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 192 | (shadowing-import 'graph:tree) 193 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 194 | 195 | 196 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 197 | (shadowing-import 'bio:tree) 198 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 199 | 200 | 201 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 202 | (defpackage :foo 203 | (:export :quux)) 204 | (defpackage :bar 205 | (:use :foo) 206 | (:export :quux)) 207 | (eql 'foo:quux 'bar:quux) 208 | (use-package '(:foo :bar)) 209 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 210 | 211 | 212 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 213 | (defvar *pics-dir* #p"/data/pictures/") 214 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 215 | 216 | 217 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 218 | (merge-pathnames "nanook.jpg" *pics-dir*) 219 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 220 | 221 | 222 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 223 | (define-symbol-macro %pics-dir% 224 | (resource-information :type :directory :data :images)) 225 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 226 | 227 | 228 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 229 | (defmacro pics-dir () 230 | '(resource-information :type :directory :data :images)) 231 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 232 | 233 | 234 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 235 | (merge-pathnames "nanook.jpg" (pics-dir)) 236 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 237 | 238 | 239 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 240 | (let ((%pics-dir% #p"/tmp/")) 241 | (merge-pathnames "nanook.jpg" %pics-dir%)) 242 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 243 | 244 | 245 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 246 | (find-symbol "FOO") 247 | 'foo 248 | (find-symbol "FOO") 249 | 'bar 250 | (export *) 251 | (defpackage :quux (:use :cl)) 252 | (in-package :quux) 253 | (find-symbol "FOO") 254 | (find-symbol "BAR") 255 | (use-package :cl-user) 256 | (find-symbol "FOO") 257 | (find-symbol "BAR") 258 | (find-all-symbols "FOO") 259 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 260 | 261 | 262 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 263 | (union (find-all-symbols "VECTOR-ADD") 264 | (find-all-symbols "VECTOR-MULT")) 265 | 266 | (let (result) 267 | (do-all-symbols (s) 268 | (when (member s '("VECTOR-ADD" "VECTOR-MULT") :test 'string=) 269 | (pushnew s result))) 270 | result) 271 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 272 | 273 | 274 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 | (loop for s being each external-symbol of :cl count s) 276 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 277 | 278 | 279 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 280 | (defpackage :quux (:use :cl)) 281 | (in-package :quux) 282 | (loop for s being each present-symbol collect s) 283 | (loop for s being each symbol of (find-package "QUUX") count t) 284 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 285 | 286 | 287 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 288 | (do-symbols (s ':cl) 289 | (when (eql (char (symbol-name s) 0) #\Y) 290 | (return s))) 291 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 292 | 293 | 294 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 295 | (readtable-case *readtable*) 296 | (symbol-name :foo) 297 | (symbol-name :FOO) 298 | (symbol-name :Foo) 299 | (symbol-name :F\oo) 300 | (setf (readtable-case *readtable*) :preserve) 301 | (SYMBOL-NAME :foo) 302 | (SYMBOL-NAME :FOO) 303 | (SYMBOL-NAME :Foo) 304 | (SYMBOL-NAME :F\oo) 305 | (SETF (READTABLE-CASE *READTABLE*) :DOWNCASE) 306 | (|SYMBOL-NAME| :foo) 307 | (|SYMBOL-NAME| :FOO) 308 | (|SYMBOL-NAME| :Foo) 309 | (|SYMBOL-NAME| :\Foo) 310 | (|SETF| (|READTABLE-CASE| |*READTABLE*|) :|INVERT|) 311 | (symbol-name :foo) 312 | (symbol-name :FOO) 313 | (symbol-name :Foo) 314 | (symbol-name :f\oo) 315 | (setf (readtable-case *readtable*) :upcase) 316 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 317 | 318 | 319 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 320 | (readtable-case *readtable*) 321 | (symbol-name :foo) 322 | :foo 323 | (symbol-name :|foo|) 324 | :|foo| 325 | *print-case* 326 | (setf *print-case* :downcase) 327 | :foo 328 | :|foo| 329 | (setf *print-case* :capitalize) 330 | :foo 331 | :|foo| 332 | (setf *print-case* :upcase) 333 | (setf (readtable-case *readtable*) :downcase) 334 | (|LIST| :foo :|FOO|) 335 | (|SETF| |*PRINT-CASE*| :|DOWNCASE|) 336 | (|LIST| :foo :|FOO|) 337 | (|SETF| |*PRINT-CASE*| :|CAPITALIZE|) 338 | (|LIST| :foo :|FOO|) 339 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 340 | 341 | 342 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 343 | (length 344 | (remove-duplicates 345 | (mapcar #'find-package '(CL :CL #:CL "CL")))) 346 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 347 | 348 | 349 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 350 | (string-capitalize :foo) 351 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 352 | 353 | 354 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 355 | (find-package "cl") 356 | (find-package '|cl|) 357 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 358 | 359 | 360 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 361 | (defpackage :my-package-1 362 | (:use :cl) 363 | (:export :important-function)) 364 | 365 | ;; ... or ... 366 | 367 | (defpackage #:my-package-2 368 | (:use #:cl) 369 | (:export #:important-function)) 370 | 371 | ;; ... or ... 372 | 373 | (defpackage "MY-PACKAGE-3" 374 | (:use "CL") 375 | (:export "IMPORTANT-FUNCTION")) 376 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 377 | 378 | 379 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 380 | (defpackage :vec 381 | (:use :cl) 382 | (:shadow :vector :+)) 383 | (in-package :vec) 384 | (defclass vector () 385 | ((x :initarg :x :reader x) 386 | (y :initarg :y :reader y))) 387 | (defgeneric + (arg &rest other-args) 388 | (:method ((arg number) &rest other-args) 389 | (apply 'cl:+ arg other-args))) 390 | (defmethod + ((arg vector) &rest other-args) 391 | (make-instance 'vector 392 | :x (apply 'cl:+ (x arg) (mapcar 'x other-args)) 393 | :y (apply 'cl:+ (y arg) (mapcar 'y other-args)))) 394 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 395 | 396 | 397 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 398 | (+ 3 4 5) 399 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 400 | 401 | 402 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 403 | (+ (make-instance 'vector :x 3 :y 4) 404 | (make-instance 'vector :x 5 :y 6) 405 | (make-instance 'vector :x 7 :y 8)) 406 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 407 | -------------------------------------------------------------------------------- /code/chapter-15/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | *default-pathname-defaults* 13 | 14 | (probe-file "passwd") 15 | (let ((*default-pathname-defaults* #p"/etc/")) 16 | (probe-file "passwd")) 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | (with-open-file (out "/tmp/foo.txt" 22 | :direction :output 23 | :if-exists :supersede) 24 | (write-string "42" out)) 25 | (probe-file #p"foo") 26 | (let ((*default-pathname-defaults* #p"/tmp/whatever.txt")) 27 | (probe-file #p"foo")) 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | 30 | 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | ;; continued from above 33 | (pathname-type #p"foo") 34 | (let ((*default-pathname-defaults* #p"/tmp/whatever.txt")) 35 | (probe-file (make-pathname :name "foo" 36 | :type :unspecific))) 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | (probe-file "/tmp/foo") 42 | (with-open-file (s "/tmp/foo" :direction :output) 43 | (write-string "bla" s)) 44 | (probe-file "/tmp/foo") 45 | (ensure-directories-exist 46 | (make-pathname :directory 47 | '(:absolute "tmp" "bar"))) 48 | (probe-file *) 49 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 50 | 51 | 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | ;; continued from above 54 | (directory "/tmp/foo*") 55 | (with-open-file (s "/tmp/foo2" :direction :output) 56 | (write-string "bla" s)) 57 | (directory "/tmp/foo*") 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | 60 | 61 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | (ensure-directories-exist "/tmp/foo/bar/") 63 | (ensure-directories-exist "/tmp/foo/bar/baz/frob" 64 | :verbose t) 65 | (ensure-directories-exist "/tmp/foo/bar/baz/frob" 66 | :verbose t) 67 | (ensure-directories-exist "/tmp/foo/bar/baz/frob/" 68 | :verbose t) 69 | ;; this will only work on AllegroCL 70 | (excl:make-directory "/tmp/bar" #o700) 71 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | 73 | 74 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 75 | (ensure-directories-exist (make-pathname :directory 76 | '(:absolute "tmp" 77 | "foo" 78 | "bar" 79 | "baz" 80 | "frob") 81 | :name "dummy")) 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | 84 | 85 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 86 | (directory (make-pathname :name :wild :type :wild 87 | :directory '(:absolute "tmp" "foo"))) 88 | (directory (make-pathname :name :wild :type "lisp" 89 | :directory '(:absolute "tmp" "foo"))) 90 | (directory (make-pathname :name "a" :type :wild 91 | :directory '(:absolute "tmp" "foo"))) 92 | (directory "/tmp/foo/*.lisp") 93 | (directory "/tmp/foo/a.*") 94 | (directory "/tmp/foo/*") 95 | (directory "/tmp/foo/*.*") 96 | (directory "/tmp/foo/ba*.lisp") 97 | (directory (make-pathname :name "ba*" :type :wild 98 | :directory "/tmp/foo/")) 99 | (directory (make-pathname :name "ba?" :type :wild 100 | :directory "/tmp/foo/")) 101 | (directory (make-pathname :name "*b*" :type :wild 102 | :directory "/tmp/foo/")) 103 | (directory "/tmp/foo/b*.lisp") 104 | (directory "/tmp/foo/b*.*") 105 | (directory "/tmp/foo/b??.lisp") 106 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 107 | 108 | 109 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 110 | ;; continued from above 111 | (directory 112 | (make-pathname :directory 113 | '(:absolute "tmp" "foo" :wild "baz") 114 | :name :wild :type :wild)) 115 | (directory 116 | (make-pathname :directory 117 | '(:absolute "tmp" "foo" :wild "baz") 118 | :name "frob*" :type :wild)) 119 | (directory 120 | (make-pathname :directory 121 | '(:absolute "tmp" "foo" :wild :wild) 122 | :name "frob*" :type :wild)) 123 | (directory "/tmp/foo/*/baz/*") 124 | (directory "/tmp/foo/*/baz/frob*") 125 | (directory "/tmp/foo/*/*/frob*") 126 | (directory "/tmp/foo/bar*/baz/frob*") 127 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 128 | 129 | 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | ;; continued from above 132 | (directory 133 | (make-pathname :directory 134 | '(:absolute "tmp" "foo" :wild-inferiors) 135 | :name "frob*" :type :wild)) 136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 137 | 138 | 139 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 | (defun split-pathspec (pathspec) 141 | (values (directory-namestring pathspec) 142 | (file-namestring pathspec))) 143 | (split-pathspec #p"/etc/passwd") 144 | (split-pathspec #p"/usr/local/lib/") 145 | (split-pathspec #p"/usr/lib/libc.so") 146 | (probe-file #p"foo.doc") 147 | (split-pathspec #p"foo.doc") 148 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 149 | 150 | 151 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 152 | (pathname-type #p"libc.so") 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | 155 | 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | (pathname-type #p"foo.tar.gz") 158 | (pathname-type #p".bashrc") 159 | (pathname-type #p"foo.") 160 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 161 | 162 | 163 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 164 | (ensure-directories-exist "/tmp/foo/dummy.txt") 165 | (directory "/tmp/foo/*.*") 166 | (with-open-file (s "/tmp/foo/a.txt" 167 | :direction :output)) 168 | (directory "/tmp/foo/*.*") 169 | (rename-file "/tmp/foo/a.txt" "/tmp/foo/b.txt") 170 | (directory "/tmp/foo/*.*") 171 | (rename-file "/tmp/foo/b.txt" "c.txt") 172 | (directory "/tmp/foo/*.*") 173 | (rename-file "/tmp/foo/c.txt" "d") 174 | (directory "/tmp/foo/*.*") 175 | (rename-file "/tmp/foo/d.txt" 176 | (make-pathname :type "lisp")) 177 | (directory "/tmp/foo/*.*") 178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 179 | 180 | 181 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 182 | (directory "/tmp/foo/*.*") 183 | (excl.osi:rename "/tmp/foo/a.txt" "/tmp/foo/b") 184 | (directory "/tmp/foo/*.*") 185 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 186 | 187 | 188 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 189 | (rename-file "foo/a.txt" "bar/b.txt") 190 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 191 | 192 | 193 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 194 | (probe-file "foo.lisp") 195 | (delete-file "foo.lisp") 196 | (probe-file "foo.lisp") 197 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 198 | 199 | 200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201 | ;; this example will only work with AllegroCL 202 | (defun delete-files (pathspec) 203 | (dolist (pathname (directory pathspec)) 204 | (unless (excl:file-directory-p pathname) 205 | (delete-file pathname)))) 206 | (directory #p"bar*" :directories-are-files nil) 207 | (delete-files #p"bar*") 208 | (directory #p"bar*" :directories-are-files nil) 209 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 210 | 211 | 212 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 213 | (probe-file #p"foo.txt") 214 | (with-open-file (out #p"foo.txt" :direction :output) 215 | (values (probe-file #p"foo.txt") 216 | (probe-file out) 217 | (progn (delete-file out) 218 | (probe-file #p"foo.txt")))) 219 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 220 | 221 | 222 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 223 | ;; example for AllegroCL 224 | (directory "/tmp/foo/*.*") 225 | (excl:delete-directory "/tmp/foo") 226 | (directory "/tmp/bar/*.*") 227 | (excl:delete-directory "/tmp/bar") 228 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 229 | 230 | 231 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 232 | (defun copy-file (from to) 233 | (let* ((element-type '(unsigned-byte 8)) 234 | (buffer (make-array 8192 :element-type element-type))) 235 | (with-open-file (in from :element-type element-type) 236 | (with-open-file (out to :element-type element-type 237 | :direction :output 238 | :if-exists :supersede) 239 | (loop (let ((position (read-sequence buffer in))) 240 | (when (zerop position) 241 | (return)) 242 | (write-sequence buffer out :end position))) 243 | (pathname out))))) 244 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 245 | 246 | 247 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 248 | (let ((tex-counter 0) 249 | (sty-counter 0)) 250 | (fad:walk-directory "C:/Users/edi/Documents/MiKTeX/" 251 | (lambda (pathname) 252 | (let ((type (pathname-type pathname))) 253 | (cond ((string-equal type "tex") 254 | (incf tex-counter)) 255 | ((string-equal type "sty") 256 | (incf sty-counter)))))) 257 | (list tex-counter sty-counter)) 258 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 259 | 260 | 261 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 262 | (let ((tex-counter 0)) 263 | (fad:walk-directory "C:/Users/edi/Documents/MiKTeX" 264 | (lambda (pathname) 265 | (declare (ignore pathname)) 266 | (incf tex-counter)) 267 | :test (lambda (pathname) 268 | (string-equal (pathname-type pathname) 269 | "tex"))) 270 | tex-counter) 271 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 272 | 273 | 274 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 275 | (with-open-file (in "/etc/passwd") 276 | (pathname in)) 277 | (let ((in (open "/etc/passwd"))) 278 | (close in) 279 | (pathname in)) 280 | (pathname *standard-output*) 281 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 282 | 283 | 284 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 285 | (let ((pathname (pathname "/etc/passwd"))) 286 | (with-open-file (in pathname) 287 | (eq pathname (pathname in)))) 288 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 289 | 290 | 291 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 292 | ;; see shell script "prepare.sh" in this directory 293 | (pathname "/tmp/foo.txt") 294 | (pathname "/tmp/bar.txt") 295 | (truename "/tmp/bar.txt") 296 | (probe-file "/tmp/quux.txt") 297 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 298 | 299 | 300 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 301 | ;; continued from above 302 | (directory "/tmp/*.txt") 303 | (directory "/tmp/*.txt" :resolve-symlinks nil) 304 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 305 | 306 | 307 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 308 | ;; see shell script "prepare2.sh" in this directory 309 | (truename "/tmp/quux/..") 310 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 311 | 312 | 313 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 314 | (truename 315 | (make-pathname :directory 316 | (list :absolute "tmp" "quux" :up))) 317 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 318 | 319 | 320 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 321 | (truename 322 | (make-pathname :directory 323 | (list :absolute "tmp" "quux" :back))) 324 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 325 | 326 | 327 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 328 | ;; see file "foo.lisp" in this directory 329 | (load (compile-file "foo.lisp")) 330 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 331 | 332 | 333 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 334 | ;; make modifications in "foo.lisp", then again... 335 | (load (compile-file "foo.lisp")) 336 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 337 | 338 | 339 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 340 | (setf (logical-pathname-translations "STUFF") 341 | '(("SOURCE;**;*.*" "D:\\Dev\\**\\*.*") 342 | ("RESOURCES;**;*.JPG" "\\\\data.quux.com\\**\\pics\\*.jpg") 343 | ("RESOURCES;**;*.*" "\\\\data.quux.com\\**\\*.*"))) 344 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 345 | 346 | 347 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 348 | (setf (logical-pathname-translations "STUFF") 349 | '(("SOURCE;**;*.*" "/usr/local/lisp/**/*.*") 350 | ("RESOURCES;**;BACKUP;**;*.*" "/mnt/bak/**/**/*.*") 351 | ("RESOURCES;**;*.*" "~/data/**/*.*"))) 352 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 353 | -------------------------------------------------------------------------------- /code/chapter-11/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (defparameter *counter* 0) 13 | (defvar *thread*) 14 | (progn 15 | (setq *thread* (bt:make-thread (lambda () 16 | (sleep 2) 17 | (incf *counter*)))) 18 | (print *thread*) 19 | (sleep 1) 20 | *counter*) 21 | ;; wait at least a second 22 | *counter* 23 | *thread* 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | (defparameter *counter* 0) 29 | (let ((thread (bt:make-thread (lambda () 30 | (sleep 5) 31 | (incf *counter*))))) 32 | (print (bt:thread-alive-p thread)) 33 | (sleep 1) 34 | (bt:destroy-thread thread) 35 | (sleep 1) 36 | (print (bt:thread-alive-p thread)) 37 | (sleep 5) 38 | *counter*) 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | 41 | 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | (defparameter *counter* 0) 44 | (let* (please-stop ;; the flag 45 | (thread (bt:make-thread 46 | (lambda () 47 | (loop repeat 5 do (sleep 1) 48 | when please-stop do (return) 49 | finally (incf *counter*)))))) 50 | (print (bt:thread-alive-p thread)) 51 | (sleep 1) 52 | (setf please-stop t) ;; raise the flag 53 | (sleep 1) 54 | (print (bt:thread-alive-p thread)) 55 | (sleep 5) 56 | *counter*) 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | 59 | 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | (loop repeat 4 do (bt:make-thread (lambda () (loop)))) 62 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | 64 | 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | (defparameter *counter* 0) 67 | 68 | (defun test () 69 | (loop repeat 100 70 | do (bt:make-thread 71 | (lambda () 72 | (loop repeat 100000 do (incf *counter*)) 73 | (loop repeat 100000 do (decf *counter*)))))) 74 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 75 | 76 | 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | (defparameter *counter* 0) 79 | 80 | (defparameter *lock* (bt:make-lock)) 81 | 82 | (defun test () 83 | (loop repeat 100 84 | do (bt:make-thread 85 | (lambda () 86 | (loop repeat 100000 do (bt:with-lock-held (*lock*) 87 | (incf *counter*))) 88 | (loop repeat 100000 do (bt:with-lock-held (*lock*) 89 | (decf *counter*))))))) 90 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 91 | 92 | 93 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 94 | (defun test () 95 | (loop repeat 100 96 | do (bt:make-thread 97 | (lambda () 98 | (loop repeat 100000 do (sys:atomic-incf *counter*)) 99 | (loop repeat 100000 do (sys:atomic-decf *counter*)))))) 100 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 101 | 102 | 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | (make-hash-table :synchronized t) 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | 107 | 108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 109 | (make-hash-table :single-thread t) 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | 112 | 113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 114 | (defparameter *a* 115 | (make-array 1000 :element-type '(signed-byte 4) 116 | :initial-element 0)) 117 | 118 | (defun writer (i) 119 | (loop repeat 100000 do 120 | (loop repeat 4 do (incf (aref *a* i))) 121 | (loop repeat 4 do (decf (aref *a* i))))) 122 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 123 | 124 | 125 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 126 | (mapc 'bt:make-thread 127 | (list (lambda () (writer 0)) 128 | (lambda () (writer 1)))) 129 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 130 | 131 | 132 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 133 | (defparameter *list* (make-list 10)) 134 | 135 | (defun swap () 136 | (let ((last-2 (last *list* 2)) 137 | (new-tail (make-list 5))) 138 | (setf (cdr (nthcdr 4 *list*)) new-tail 139 | (cdr last-2) nil))) 140 | 141 | (defun writer () 142 | (loop repeat 1000000 143 | do (swap))) 144 | 145 | (defparameter *results* nil) 146 | 147 | (defun reader () 148 | (loop repeat 1000000 149 | do (pushnew (length *list*) *results*))) 150 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 151 | 152 | 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | (mapc 'bt:make-thread '(writer reader)) 155 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | 157 | 158 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | (defparameter *foo* 42) 160 | (defparameter *results* nil) 161 | (bt:make-thread (lambda () (push *foo* *results*))) 162 | *results* 163 | (let ((*foo* :yo)) 164 | (bt:make-thread (lambda () (push *foo* *results*)))) 165 | *results* 166 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 167 | 168 | 169 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 170 | (defparameter *foo* 42) 171 | (defparameter *results* nil) 172 | (map nil 'bt:make-thread 173 | (list (lambda () 174 | (let ((*foo* 1)) 175 | (sleep .1) 176 | (push (cons 1 *foo*) *results*))) 177 | (lambda () 178 | (let ((*foo* 2)) 179 | (sleep .1) 180 | (push (cons 2 *foo*) *results*))))) 181 | *results* 182 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 183 | 184 | 185 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 186 | (bt:make-thread (lambda () (print 42))) 187 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 188 | 189 | 190 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 191 | (bt:make-thread (lambda () (print 42 #.*standard-output*))) 192 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 193 | 194 | 195 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 196 | (defparameter *foo* 42) 197 | (defparameter *results* nil) 198 | (let ((bt:*default-special-bindings* '((*foo* . :yo)))) 199 | (bt:make-thread (lambda () (push *foo* *results*)))) 200 | *results* 201 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 202 | 203 | 204 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 205 | (let* ((state :not-yet-started) 206 | (thread (bt:make-thread 207 | (lambda () 208 | (sleep 3) 209 | (setf state :finished))))) 210 | (bt:join-thread thread) 211 | state) 212 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 213 | 214 | 215 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 216 | (defparameter *new-result* nil) 217 | 218 | (defun producer () 219 | (dotimes (i 5) 220 | (setf *new-result* (* i i)) 221 | (sleep 1)) 222 | (setf *new-result* :done)) 223 | 224 | (defun consumer () 225 | (setf *new-result* nil) 226 | (bt:make-thread 'producer) 227 | (loop 228 | (case *new-result* 229 | (:done (return)) 230 | ((nil)) 231 | (otherwise (print *new-result*) 232 | (setf *new-result* nil))) 233 | (sleep .001))) 234 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 235 | 236 | 237 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 238 | (defparameter *new-result* nil) 239 | 240 | (defun producer (cv lock) 241 | (flet ((set-value-and-notify (new-value) 242 | (bt:with-lock-held (lock) 243 | (setf *new-result* new-value) 244 | (bt:condition-notify cv)))) 245 | (dotimes (i 5) 246 | (set-value-and-notify (* i i)) 247 | (sleep 1)) 248 | (set-value-and-notify :done))) 249 | 250 | (defun consumer () 251 | (let ((cv (bt:make-condition-variable)) 252 | (lock (bt:make-lock))) 253 | (bt:make-thread (lambda () (producer cv lock))) 254 | (loop 255 | (bt:with-lock-held (lock) 256 | (bt:condition-wait cv lock) 257 | (when (eql *new-result* :done) 258 | (return)) 259 | (print *new-result*))))) 260 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 261 | 262 | 263 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 264 | (defun seed () 265 | (random 100000000)) 266 | 267 | (deftype von-neumann () 268 | '(integer 0 99999999)) 269 | 270 | (defun middle-square (seed n) 271 | (declare (optimize speed) 272 | (type von-neumann seed) 273 | (fixnum n)) 274 | (loop for i below n 275 | for val of-type von-neumann = seed 276 | then (mod (floor (* val val) 10000) 100000000) 277 | finally (return val))) 278 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 279 | 280 | 281 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 282 | (defparameter *seeds* 283 | (coerce (loop repeat 40000 collect (seed)) 'vector)) 284 | 285 | (defparameter *repetitions* 286 | (coerce (loop repeat 40000 collect (random 100000)) 'vector)) 287 | 288 | (defun test () 289 | (map 'vector 'middle-square *seeds* *repetitions*)) 290 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 291 | 292 | 293 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 294 | (setf lparallel:*kernel* (lparallel:make-kernel 4)) 295 | 296 | (defun ptest () 297 | (lparallel:pmap 'vector 'middle-square *seeds* *repetitions*)) 298 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 299 | 300 | 301 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 302 | (defun mult (a b) 303 | ;; number of bits the larger factor has 304 | (let ((length (max (integer-length a) (integer-length b)))) 305 | (when (< length 100000) 306 | ;; numbers are "small" 307 | (return-from mult (* a b))) 308 | (let* ((length/2 (floor length 2)) ;; half of the bits 309 | (mask (1- (ash 1 length/2))) ;; bitmask for right half 310 | (a1 (ash a (- length/2))) ;; left half of A 311 | (a2 (logand a mask)) ;; right half of A 312 | (b1 (ash b (- length/2))) ;; left half of B 313 | (b2 (logand b mask)) ;; right half of B 314 | (a1*b1 (mult a1 b1)) 315 | (a2*b2 (mult a2 b2)) 316 | (prod3 (mult (+ a1 a2) (+ b1 b2)))) 317 | (+ (ash a1*b1 (* 2 length/2)) 318 | a2*b2 319 | (ash (+ prod3 320 | (- a1*b1) 321 | (- a2*b2)) 322 | length/2))))) 323 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 324 | 325 | 326 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 327 | (defun pmult% (a b tree) 328 | (let ((length (max (integer-length a) (integer-length b)))) 329 | (when (< length 100000) 330 | (let ((result (gensym))) 331 | ;; add function to ptree using name RESULT 332 | (lparallel:ptree-fn result () 333 | ;; this function has no dependencies 334 | (lambda () (* a b)) 335 | tree) 336 | ;; return this name 337 | (return-from pmult% result))) 338 | (let* ((length/2 (floor length 2)) 339 | (mask (1- (ash 1 length/2))) 340 | (a1 (ash a (- length/2))) 341 | (a2 (logand a mask)) 342 | (b1 (ash b (- length/2))) 343 | (b2 (logand b mask)) 344 | ;; the following three are now symbols instead of numbers 345 | (a1*b1 (pmult% a1 b1 tree)) 346 | (a2*b2 (pmult% a2 b2 tree)) 347 | (prod3 (pmult% (+ a1 a2) (+ b1 b2) tree)) 348 | (result (gensym))) 349 | ;; add function to ptree using name RESULT and 350 | ;; tell lparallel which results this'll depend on 351 | (lparallel:ptree-fn result (list a1*b1 a2*b2 prod3) 352 | (lambda (a1*b1 a2*b2 prod3) 353 | (+ (ash a1*b1 (* 2 length/2)) 354 | a2*b2 355 | (ash (+ prod3 356 | (- a1*b1) 357 | (- a2*b2)) 358 | length/2))) 359 | tree) 360 | ;; return the name as above 361 | result))) 362 | 363 | (defun pmult (a b) 364 | (let ((tree (lparallel:make-ptree))) 365 | (lparallel:call-ptree (pmult% a b tree) tree))) 366 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 367 | 368 | 369 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 370 | (setf lparallel:*kernel* (lparallel:make-kernel 4)) 371 | 372 | (defparameter *a* (random (expt 2 1000000))) 373 | (defparameter *b* (random (expt 2 1000000))) 374 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 375 | 376 | 377 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 378 | (time (defparameter *p1* (mult *a* *b*))) 379 | (time (defparameter *p2* (pmult *a* *b*))) 380 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 381 | 382 | 383 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 384 | (defconstant +sc-nprocessors-onln+ 84) 385 | 386 | (cffi:defcfun "sysconf" :long 387 | (name :int)) 388 | 389 | (defun get-number-of-processors () 390 | (sysconf +sc-nprocessors-onln+)) 391 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 392 | 393 | 394 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 395 | (cffi:defctype dword :unsigned-long) 396 | (cffi:defctype word :unsigned-short) 397 | 398 | (cffi:defcstruct processor-struct 399 | (processor-architecture word) 400 | (reserved word)) 401 | 402 | (cffi:defcunion oem-union 403 | (oem-ide dword) 404 | (processor-struct (:struct processor-struct))) 405 | 406 | (cffi:defcstruct system-info 407 | (oem-info (:union oem-union)) 408 | (page-size dword) 409 | (minimum-application-address :pointer) 410 | (maximum-application-address :pointer) 411 | (active-processor-mask (:pointer dword)) 412 | (number-of-processors dword) 413 | (processor-type dword) 414 | (allocation-granularity dword) 415 | (processor-level word) 416 | (processor-revision word)) 417 | 418 | (cffi:defcfun ("GetSystemInfo" get-system-info) :void 419 | (data (:pointer (:struct system-info)))) 420 | 421 | (defun get-number-of-processors () 422 | (cffi:with-foreign-object (info '(:struct system-info)) 423 | (get-system-info info) 424 | (cffi:foreign-slot-value info '(:struct system-info) 425 | 'number-of-processors))) 426 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 427 | -------------------------------------------------------------------------------- /code/chapter-02/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (cons 42 #\X) 13 | (car *) 14 | (cdr **) 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | (cons 'foo 'bar) 20 | '(foo . bar) 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | (cons (make-array 1 :initial-element 23) 26 | "23") 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | (cons (cons 1 2) :foo) 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | 34 | 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | (cons 'a (cons 'b (cons 'c (cons 'd nil)))) 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | (cons 1 (cons 3 4)) 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | 44 | 45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 46 | (cons 42 nil) 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | 49 | 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | nil 52 | (cons 1 2) 53 | (cons (cons 1 2) 3) 54 | (cons (cons (cons 1 2) 3) 4) 55 | (cons 1 (cons 2 (cons 3 4))) 56 | (cons 1 (cons 2 (cons 3 nil))) 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | 59 | 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | (list 1 2 3) 62 | (list 1) 63 | (list) 64 | (list 1 2 (list 3 4)) 65 | (list* 1 2 (list 3 4)) 66 | (make-list 4 :initial-element 42) 67 | (make-list 4) 68 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 | 70 | 71 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 72 | (coerce #(3 2 1 0) 'list) 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | 75 | 76 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 77 | (map 'list 'identity #(3 2 1 0)) 78 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | (coerce "Frunobulax" 'list) 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | 85 | 86 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 87 | (defun integer-to-bit-list (x) 88 | (check-type x (integer 0 *)) 89 | (reverse (map 'list 'digit-char-p (write-to-string x :base 2)))) 90 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 91 | 92 | 93 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 94 | (defun integer-to-bit-list (x) 95 | (check-type x (integer 0 *)) 96 | (let (result) 97 | (loop (when (zerop x) 98 | (return (nreverse result))) 99 | (push (logand x 1) result) 100 | (setf x (ash x -1))))) 101 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 102 | 103 | 104 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 | (defparameter *m* 106 | '((11 12 13 14) 107 | (21 22 23 24) 108 | (31 32 33 34))) 109 | (let ((*print-right-margin* 20)) 110 | (pprint (apply 'mapcar 'list *m*))) 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | 113 | 114 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 115 | (mapcar 'list '(11 12 13 14) '(21 22 23 24) '(31 32 33 34)) 116 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 | 118 | 119 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 120 | `(a b c) 121 | '(a b c) 122 | (quote (a b c)) 123 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 | 125 | 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | (let ((b 42)) 128 | `(a ,b c)) 129 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 130 | 131 | 132 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 133 | (let ((b (list 23 42))) 134 | `(a ,@b c)) 135 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 136 | 137 | 138 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 | (let ((x 'f) 140 | (y (list 'g nil nil))) 141 | `(a (b (d nil nil) (e nil nil)) 142 | (c (,x nil nil) (,@y)))) 143 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 144 | 145 | 146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | (let ((list '(3 4))) 148 | `(1 2 . ,list)) 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | 151 | 152 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 153 | (let ((list '(3 4))) 154 | `#(1 2 ,@list 5)) 155 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | 157 | 158 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | (flet ((foo (x) 160 | `(,x b c))) 161 | (let ((a (foo 23)) 162 | (b (foo 42))) 163 | (list a b (eq a b) (eq (cdr a) (cdr b))))) 164 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 165 | 166 | 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | (defparameter *list* (list 'a 'b 'c)) 169 | (setf *list* (append *list* (list 'd))) 170 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 171 | 172 | 173 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 174 | (let (list) 175 | (dotimes (i 10) 176 | (setf list (append list (list (* i i))))) 177 | list) 178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 179 | 180 | 181 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 182 | (let (list) 183 | (dotimes (i 10) 184 | (push (* i i) list)) 185 | (nreverse list)) 186 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 187 | 188 | 189 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 190 | (defparameter *list* (list 'a 'b 'c 'd)) 191 | (defparameter *tail* (cdddr *list*)) ;; or (LAST *LIST*) 192 | *tail* 193 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 194 | 195 | 196 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 197 | ;; continued from above 198 | (setf (cdr *tail*) (cons 'e 'nil) 199 | *tail* (cdr *tail*)) 200 | *list* 201 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 202 | 203 | 204 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 205 | (let (list tail) 206 | (dotimes (i 10) 207 | (let ((new-tail (cons (* i i) nil))) 208 | (cond ((null list) (setf list new-tail)) 209 | (t (setf (cdr tail) new-tail))) 210 | (setf tail new-tail))) 211 | list) 212 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 213 | 214 | 215 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 216 | (loop for i below 10 collect (* i i)) 217 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 218 | 219 | 220 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 221 | (defparameter *list* (list 1 2 3 42 5)) 222 | (nth 3 *list*) 223 | (setf (nth 3 *list*) 4) 224 | *list* 225 | (subseq *list* 2 4) 226 | (setf (subseq *list* 2 4) (list :three :four)) 227 | *list* 228 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 229 | 230 | 231 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 232 | (defparameter *new* (list 'x 'y 'z)) 233 | (setf *list* (splice *list* :start 1 :end 3 :new *new*)) 234 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 235 | 236 | 237 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 238 | (defun splice (list &key (start 0) (end (length list)) new) 239 | (setf list (cons nil list)) ;; add dummy cell 240 | (let ((reroute-start (nthcdr start list))) 241 | (setf (cdr reroute-start) 242 | (nconc (make-list (length new)) ;; empty cons cells 243 | (nthcdr (- end start) ;; tail of old list 244 | (cdr reroute-start))) 245 | list (cdr list))) ;; remove dummy cell 246 | (replace list new :start1 start) ;; fill empty cells 247 | list) 248 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 249 | 250 | 251 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 252 | (defparameter *list* (list 'a 'b 'c 'd 'e)) 253 | (defparameter *new* (list 'x 'y 'z)) 254 | (setf *list* (splice *list* :start 1 :end 3 :new *new*)) 255 | *new* 256 | (splice *list* :start 1 :end 4) 257 | (splice *list* :start 2 :new (list 1 2 3)) 258 | (splice *list* :start 3 :end 3 :new (list 42)) 259 | *list* 260 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 261 | 262 | 263 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 264 | (defparameter *list* (list 'a 'b 'c 'd 'e)) 265 | (splice *list* :end 3 :new (list 1 2 3)) 266 | *list* 267 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 268 | 269 | 270 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 271 | (defparameter *a* (list :a :b :c :d :e)) 272 | (defparameter *b* (list :b :c :d :e)) 273 | (list *a* *b*) 274 | (tailp *b* *a*) 275 | (tailp (cdr *b*) *a*) 276 | (let ((tail (list :c :d :e))) 277 | (setf *a* (append (list :a :b) tail) 278 | *b* (cons :b tail))) 279 | (list *a* *b*) 280 | (eql *a* *b*) 281 | (tailp *b* *a*) 282 | (tailp (cdr *b*) *a*) 283 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 284 | 285 | 286 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 287 | (tailp nil '(1 2 3)) ;; NIL is a tail of every proper list 288 | (tailp 42 '(1 2 . 42)) ;; TAILP accepts dotted lists 289 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 290 | 291 | 292 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 293 | (defun my-tailp (object list) 294 | (check-type list list) 295 | (loop for tail = list then (cdr tail) 296 | until (prog1 (atom tail) 297 | (when (eql object tail) (return t))))) 298 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 299 | 300 | 301 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 302 | ;; continued from above 303 | (tailp (cdr *b*) *a*) 304 | (ldiff *a* (cdr *b*)) 305 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 306 | 307 | 308 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 309 | (defparameter *a* '(42 "3" 5.3 :x #\u :a 23/12)) 310 | (ldiff *a* (member-if 'symbolp *a*)) 311 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 312 | 313 | 314 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 315 | (cons (cons 'A 'B) (cons 'C 'D)) 316 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 317 | 318 | 319 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 320 | (defun node-value (node) 321 | (car node)) ;; or (FIRST NODE) 322 | 323 | (defun left-child (node) 324 | (cadr node)) ;; or (SECOND NODE) 325 | 326 | (defun right-child (node) 327 | (caddr node)) ;; or (THIRD NODE) 328 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 329 | 330 | 331 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 332 | (defun make-node (&key value left-child right-child) 333 | (list value left-child right-child)) 334 | 335 | (defun (setf node-value) (new-value node) 336 | (setf (car node) new-value)) 337 | 338 | (defun (setf left-child) (new-child node) 339 | (setf (cadr node) new-child)) 340 | 341 | (defun (setf right-child) (new-child node) 342 | (setf (caddr node) new-child)) 343 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 344 | 345 | 346 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 347 | (let ((tree (make-node :value 'a))) 348 | (setf (left-child tree) 349 | (make-node :value 'b 350 | :left-child (make-node :value 'd) 351 | :right-child (make-node :value 'e)) 352 | (right-child tree) 353 | (make-node :value 'c 354 | :left-child (make-node :value 'f) 355 | :right-child (make-node :value 'g))) 356 | tree) 357 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 358 | 359 | 360 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 361 | (ql:system-apropos "tree") 362 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 363 | 364 | 365 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 366 | (defparameter *stack* nil) 367 | (push :plate *stack*) 368 | (push :another-plate *stack*) 369 | (pop *stack*) 370 | *stack* 371 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 372 | 373 | 374 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 375 | (defclass queue () 376 | ((list :initform nil) 377 | (tail :initform nil))) 378 | 379 | (defmethod print-object ((queue queue) stream) 380 | (print-unreadable-object (queue stream :type t) 381 | (with-slots (list tail) queue 382 | (cond ((cddddr list) 383 | ;; at least five elements, so print ellipsis 384 | (format stream "(~{~S ~}... ~S)" 385 | (subseq list 0 3) (first tail))) 386 | ;; otherwise print whole list 387 | (t (format stream "~:S" list)))))) 388 | 389 | (defmethod dequeue ((queue queue)) 390 | (with-slots (list) queue 391 | (pop list))) 392 | 393 | (defmethod enqueue (new-item (queue queue)) 394 | (with-slots (list tail) queue 395 | (let ((new-tail (list new-item))) 396 | (cond ((null list) (setf list new-tail)) 397 | (t (setf (cdr tail) new-tail))) 398 | (setf tail new-tail))) 399 | queue) 400 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 401 | 402 | 403 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 404 | (defparameter *q* (make-instance 'queue)) 405 | *q* 406 | (enqueue 42 *q*) 407 | (enqueue :foo *q*) 408 | (dotimes (i 5 *q*) 409 | (enqueue i *q*)) 410 | (dequeue *q*) 411 | *q* 412 | (dequeue *q*) 413 | *q* 414 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 415 | 416 | 417 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 418 | (destructuring-bind (a (b &rest c) (d (e . f))) 419 | '("A" (:b 2 3) (#\D (1.0 . 3.0))) 420 | (list a b c d e f)) 421 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 422 | 423 | 424 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 425 | (destructuring-bind (&key a (b :not-found) c &allow-other-keys) 426 | '(:c 23 :d "D" :a #\A :foo :whatever) 427 | (list a b c)) 428 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 429 | 430 | 431 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 432 | (ql:quickload '(:optima 433 | :fare-quasiquote-optima 434 | :fare-quasiquote-readtable)) 435 | (named-readtables:in-readtable :fare-quasiquote) 436 | (optima:match (list 42 23) 437 | (`(,x ,_ ,_) (list :three x)) 438 | (`(,x ,_) (list :two x))) 439 | (optima:match (list 42 23) 440 | (`(41 ,x) x) 441 | (`(,x 23) x)) 442 | (optima:match '(1 (2 (3 4 5 6) 7 8) 9) 443 | (`(1 (2 (3 ,x) 7 8) 9) (list :one x)) 444 | (`(1 (2 (3 ,x . ,_) 7 8) 9) (list :two x))) 445 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 446 | -------------------------------------------------------------------------------- /code/chapter-12/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (defun my-sqrt (x) 13 | (check-type x (real 0)) 14 | (sqrt x)) 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | (defun my-sqrt (list) 20 | (check-type (first list) (real 0) "a non-negative real number") 21 | (sqrt (first list))) 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | (defparameter *l* (list -9 :whatever)) 27 | (my-sqrt *l*) 28 | *l* 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | (defun my-sqrt (x) 34 | (declare (type (real 0) x)) 35 | (sqrt x)) 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | (defun dot-product (x y) 41 | (assert (and (typep x '(or list vector)) 42 | (typep y '(or list vector)) 43 | (= (length x) (length y))) 44 | (x y) 45 | "~S and ~S should have been sequences of the same length." 46 | x y) 47 | (reduce '+ (map 'list '* x y))) 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | 50 | 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | (dot-product '(2 3 4) '(4)) 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | 55 | 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | (defmacro assert* (test-form &rest other-args) 58 | (declare (ignorable test-form other-args)) 59 | #-:release 60 | `(assert ,test-form ,@other-args)) 61 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | 63 | 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | (pushnew :release *features*) 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | 68 | 69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 | (define-condition too-expensive (error) 71 | ((price :initarg :price 72 | :reader price)) 73 | (:report (lambda (condition stream) 74 | (format stream "At ~A Euro~:P that's too expensive." 75 | (price condition))))) 76 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 77 | 78 | 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | (make-condition 'too-expensive :price 42) 81 | (format nil "~A" *) 82 | (error **) 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | 85 | 86 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 87 | (signal (make-condition 'error)) 88 | (list (signal (make-condition 'error)) 42) 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | 91 | 92 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 93 | (handler-case 94 | (list (signal (make-condition 'error)) 42) 95 | (error () 96 | (list :foo :bar))) 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | 99 | 100 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 101 | (list (error (make-condition 'error)) 42) 102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 | 104 | 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | (handler-case 107 | (list (error (make-condition 'error)) 42) ;; changed 108 | (error () 109 | (list :foo :bar))) 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | 112 | 113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 114 | (list (cerror "Proceed." (make-condition 'error)) 42) 115 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 116 | 117 | 118 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 119 | (list (warn (make-condition 'warning)) 42) 120 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 121 | 122 | 123 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 | (signal 'unbound-variable :name 'foo) 125 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 126 | 127 | 128 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 129 | (signal (make-condition 'unbound-variable :name 'foo)) 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | 132 | 133 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 134 | (error "~S and ~S don't match." :foo "FOO") 135 | 136 | (error (make-condition 'simple-error ;; <- default type 137 | :format-control "~S and ~S don't match." 138 | :format-arguments (list :foo "FOO"))) 139 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 | 141 | 142 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 | (warn "~S and ~S don't match." :foo "FOO") 144 | 145 | (warn (make-condition 'simple-warning ;; <- default type 146 | :format-control "~S and ~S don't match." 147 | :format-arguments (list :foo "FOO"))) 148 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 149 | 150 | 151 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 152 | (defun test (a b) 153 | (handler-case 154 | (/ a b) 155 | (type-error (condition) 156 | (format *error-output* 157 | "Oops, ~S should have been of type ~A." 158 | (type-error-datum condition) 159 | (type-error-expected-type condition)) 160 | :no-meaningful-result) 161 | (division-by-zero () 162 | (format *error-output* "This might create black holes!") 163 | (values)))) 164 | (test 42 7) 165 | (test 42 "23") 166 | (test 42 0) 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | 169 | 170 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 171 | (test most-positive-double-float least-positive-double-float) 172 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 173 | 174 | 175 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 176 | (defparameter *special* :old) 177 | (defun div (x y) 178 | (let ((*special* :new)) 179 | (catch 'catch-tag 180 | (/ x y)))) 181 | (defun test (a b) 182 | (handler-case 183 | (div a b) 184 | (type-error (condition) 185 | (format *error-output* 186 | "Oops, ~S should have been of type ~A." 187 | (type-error-datum condition) 188 | (type-error-expected-type condition)) 189 | *special*) 190 | (division-by-zero () 191 | (format *error-output* "This might create black holes!") 192 | (throw 'catch-tag -1)))) 193 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 194 | 195 | 196 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 197 | (test 100 "NaN") 198 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 199 | 200 | 201 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 202 | (test 42 0) 203 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 204 | 205 | 206 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 207 | (defparameter *special* :old) 208 | 209 | (defun div (x y) 210 | (let ((*special* :new)) 211 | (catch 'catch-tag 212 | (/ x y)))) 213 | 214 | (defun handler-2 (condition) 215 | (declare (ignore condition)) 216 | (format *error-output* "This might create black holes!") 217 | (throw 'catch-tag -1)) 218 | 219 | (defun test (a b) 220 | (flet ((handler-1 (condition) 221 | (format *error-output* 222 | "Oops, ~S should have been of type ~A." 223 | (type-error-datum condition) 224 | (type-error-expected-type condition)) 225 | (return-from test *special*))) 226 | (handler-bind ((type-error #'handler-1) 227 | (division-by-zero #'handler-2)) 228 | (div a b)))) 229 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 230 | 231 | 232 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 233 | (test 100 "NaN") 234 | (test 42 0) 235 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 236 | 237 | 238 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 239 | (ignore-errors (parse-integer "42")) 240 | (ignore-errors (parse-integer "fourty-two")) 241 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 242 | 243 | 244 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 245 | (define-condition not-a-percentage (error) 246 | ((dividend :initarg :dividend 247 | :reader dividend) 248 | (divisor :initarg :divisor 249 | :reader divisor)) 250 | (:report (lambda (condition stream) 251 | (format stream "The quotient ~A/~A is not between 0 and 1." 252 | (dividend condition) (divisor condition))))) 253 | 254 | (defun percentage (a b) 255 | (restart-case 256 | (let ((ratio (/ a b))) 257 | (unless (typep ratio '(real 0 1)) 258 | (error 'not-a-percentage :dividend a :divisor b)) 259 | (format nil "~,2F%" (* 100 ratio))) 260 | (use-other-values (new-a new-b) 261 | :report "Use two other values instead." 262 | :interactive (lambda () 263 | (flet ((get-value (name) 264 | (format t "~&Enter new value for ~A: " 265 | name) 266 | (read))) 267 | (list (get-value 'a) (get-value 'b)))) 268 | (format nil "~,2F%" (* 100 (/ new-a new-b)))))) 269 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 270 | 271 | 272 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 273 | (percentage 3 7) 274 | (percentage 4 2) 275 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 276 | 277 | 278 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 279 | (defun percentage (a b) 280 | (restart-case 281 | (let ((ratio (/ a b))) 282 | (unless (typep ratio '(real 0 1)) 283 | (error 'not-a-percentage :dividend a :divisor b)) 284 | (format nil "~,2F%" (* 100 ratio))) 285 | (use-other-values (new-a new-b) 286 | :report "Use two other values instead." 287 | :interactive (lambda () 288 | (flet ((get-value (name) 289 | (format t "~&Enter new value for ~A: " 290 | name) 291 | (read))) 292 | (list (get-value 'a) (get-value 'b)))) 293 | (percentage new-a new-b)))) ;; <-- changed 294 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 295 | 296 | 297 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 298 | (handler-bind ((not-a-percentage (lambda (condition) 299 | (declare (ignore condition)) 300 | (invoke-restart 'use-other-values 301 | 1 10)))) 302 | (percentage 4 2)) 303 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 304 | 305 | 306 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 307 | (defun divide-by-three (arg) 308 | (loop (restart-case 309 | (let ((type-error (make-condition 'type-error 310 | :expected-type 'integer 311 | :datum arg))) 312 | (with-condition-restarts 313 | type-error 314 | (list (find-restart 'parse-string)) 315 | (cond ((stringp arg) (error type-error)) 316 | ((zerop (mod arg 3)) (return (/ arg 3))) 317 | (t (error "Not divisible by three."))))) 318 | (parse-string () 319 | (setf arg (parse-integer arg))) 320 | (increase-value () 321 | :test (lambda (condition) 322 | (declare (ignore condition)) 323 | (typep arg 'integer)) 324 | (incf arg)) 325 | (decrease-value () 326 | :test (lambda (condition) 327 | (declare (ignore condition)) 328 | (typep arg '(integer 2))) 329 | (decf arg))))) 330 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 331 | 332 | 333 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 334 | (divide-by-three 2) 335 | (divide-by-three 1) 336 | (divide-by-three "3") 337 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 338 | 339 | 340 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 341 | (define-condition too-many-iterations (error) 342 | ()) 343 | 344 | (defun collatz (start &optional (max 10)) 345 | (let ((count 0) 346 | (value start)) 347 | (loop (incf count) 348 | (setf value (if (evenp value) 349 | (/ value 2) 350 | (1+ (* 3 value)))) 351 | (when (= value 1) 352 | (return)) 353 | (when (>= count max) 354 | (cerror "Continue trying?" 'too-many-iterations) 355 | (setf max (* 2 max)))) 356 | (format t "Reached end after ~A iterations." count))) 357 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 358 | 359 | 360 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 361 | (handler-bind ((too-many-iterations #'continue)) 362 | (collatz 6171)) 363 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 364 | 365 | 366 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 367 | (defun my-expt (base power) 368 | (unless (and (typep power 'integer) 369 | (typep base '(or rational (complex rational)))) 370 | (warn "Result may have round-off errors.")) 371 | (expt base power)) 372 | (my-expt 10 (log 1/4 10)) 373 | (handler-bind ((warning #'muffle-warning)) 374 | (my-expt 10 (log 1/4 10))) 375 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 376 | 377 | 378 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 379 | (defclass fridge () 380 | ((door-open-p :initform nil 381 | :accessor door-open-p) 382 | (eggs :initform 10 383 | :accessor eggs))) 384 | 385 | (define-condition fridge-error (error) 386 | ((fridge :initarg :fridge 387 | :reader fridge))) 388 | 389 | (define-condition no-eggs (fridge-error) ()) 390 | 391 | (defmethod open-door ((fridge fridge)) 392 | (setf (door-open-p fridge) t)) 393 | 394 | (defmethod close-door ((fridge fridge)) 395 | (setf (door-open-p fridge) nil)) 396 | 397 | (defmethod remove-egg ((fridge fridge)) 398 | (unless (plusp (eggs fridge)) 399 | (error 'no-eggs :fridge fridge)) 400 | (decf (eggs fridge))) 401 | 402 | (defmethod get-some-eggs ((fridge fridge) n) 403 | (open-door fridge) 404 | (loop repeat n do (remove-egg fridge)) 405 | (close-door fridge) 406 | ;; return number of eggs left 407 | (eggs fridge)) 408 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 409 | 410 | 411 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 412 | (defparameter *fridge* (make-instance 'fridge)) 413 | (door-open-p *fridge*) 414 | (get-some-eggs *fridge* 7) 415 | (door-open-p *fridge*) 416 | (handler-bind ((no-eggs #'abort)) 417 | (get-some-eggs *fridge* 4)) 418 | (door-open-p *fridge*) 419 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 420 | 421 | 422 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 423 | (defmethod get-some-eggs ((fridge fridge) n) 424 | (open-door fridge) 425 | (unwind-protect 426 | (loop repeat n do (remove-egg fridge)) 427 | (close-door fridge)) 428 | (eggs fridge)) 429 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 430 | 431 | 432 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 433 | ;; continued from above 434 | (setf (eggs *fridge*) 4) 435 | (close-door *fridge*) 436 | (handler-bind ((no-eggs #'abort)) 437 | (get-some-eggs *fridge* 7)) 438 | (door-open-p *fridge*) 439 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 440 | -------------------------------------------------------------------------------- /code/chapter-06/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (defparameter *h* (make-hash-table)) 13 | (gethash 'batman *h*) 14 | (setf (gethash 'batman *h*) 'gotham-city) 15 | (gethash 'batman *h*) 16 | (setf (gethash 'superman *h*) 'duckburg) 17 | (gethash 'superman *h*) 18 | (setf (gethash 'superman *h*) 'metropolis) 19 | (gethash 'superman *h*) 20 | (gethash 'spider-man *h*) 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | (setf (gethash 'lois-lane *h*) 'metropolis) 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | (defparameter *h* (make-hash-table)) 31 | (gethash 'batman *h*) 32 | (setf (gethash 'batman *h*) nil) 33 | (gethash 'batman *h*) 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | 36 | 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | (defparameter *h* (make-hash-table)) 39 | (setf (gethash 'gladstone-gander *h*) 'goose) 40 | (setf (gethash 'gyro-gearloose *h*) 'chicken) 41 | (defun duckburg-species (name) 42 | (gethash name *h*)) 43 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 | 45 | 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | (duckburg-species 'gyro-gearloose) 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | 50 | 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | (defun duckburg-species (name) 53 | (gethash name *h* 'duck)) 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | 56 | 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | (duckburg-species 'gyro-gearloose) 59 | (duckburg-species 'donald-duck) 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | 62 | 63 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 64 | (defun duckburg-species (name) 65 | (or (gethash name *h*) 'duck)) 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | 68 | 69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 | (defparameter *h* (make-hash-table)) 71 | (setf (gethash 'batman *h*) 'gotham-city) 72 | (setf (gethash 'superman *h*) 'metropolis) 73 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 74 | 75 | 76 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 77 | (setf (gethash 'superman *h*) nil) 78 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | (remhash 'superman *h*) 83 | (gethash 'superman *h*) 84 | (hash-table-count *h*) 85 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 86 | 87 | 88 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 89 | (defparameter *h* (make-hash-table)) 90 | (loop for (key value) in '((superman 1938) 91 | (donald-duck 1934) 92 | (batman 1939)) do 93 | (setf (gethash key *h*) value)) 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | 96 | 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | (let ((min 2015) oldest) 99 | (maphash (lambda (hero year) 100 | (when (< year min) 101 | (setf min year 102 | oldest hero))) 103 | *h*) 104 | oldest) 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | 107 | 108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 109 | (let ((min 2015) oldest) 110 | (with-hash-table-iterator (next-hero *h*) 111 | (loop 112 | (multiple-value-bind (not-done hero year) 113 | (next-hero) 114 | (unless not-done 115 | (return oldest)) 116 | (when (< year min) 117 | (setf min year 118 | oldest hero)))))) 119 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 120 | 121 | 122 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 123 | (defun my-maphash (function hash-table) 124 | (with-hash-table-iterator (next-entry hash-table) 125 | (loop (multiple-value-bind (more key value) 126 | (next-entry) 127 | (unless more (return nil)) 128 | (funcall function key value))))) 129 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 130 | 131 | 132 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 133 | (defun hero-from (this-year) 134 | (with-hash-table-iterator (next-hero *h*) 135 | (loop 136 | (multiple-value-bind (not-done hero year) 137 | (next-hero) 138 | (unless not-done 139 | (return nil)) 140 | (when (= year this-year) 141 | ;; skip the rest, we're done 142 | (return hero)))))) 143 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 144 | 145 | 146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | (loop with min = 2015 and oldest 148 | for hero being the hash-keys of *h* 149 | using (hash-value year) 150 | when (< year min) 151 | do (setf min year 152 | oldest hero) 153 | finally (return oldest)) 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | 156 | 157 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 158 | (loop with min = 2015 and oldest 159 | for year being the hash-values of *h* 160 | using (hash-key hero) 161 | when (< year min) 162 | do (setf min year 163 | oldest hero) 164 | finally (return oldest)) 165 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 166 | 167 | 168 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 169 | (loop for hero being the hash-keys of *h* 170 | collect hero) 171 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 172 | 173 | 174 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 175 | (loop for hero being the hash-keys of *h* 176 | using (hash-value year) 177 | when (< year 1935) 178 | do (remhash hero *h*)) 179 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 180 | 181 | 182 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 183 | ;; don't do that! 184 | (loop for hero being the hash-keys of *h* 185 | using (hash-value year) 186 | when (eql hero 'batman) 187 | do (setf (gethash 'robin *h*) (1+ year))) 188 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 189 | 190 | 191 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 192 | (defmacro dohash ((key-name value-name hash-table) &body body) 193 | (let ((next (gensym "NEXT")) 194 | (more (gensym "MORE"))) 195 | `(with-hash-table-iterator (,next ,hash-table) 196 | (loop (multiple-value-bind (,more ,key-name ,value-name) 197 | (,next) 198 | (unless ,more (return nil)) 199 | ,@body))))) 200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201 | 202 | 203 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 204 | (dohash (hero year *h*) 205 | (format t "~A: ~A~%" year hero)) 206 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 207 | 208 | 209 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 210 | (iter (for (hero year) in-hashtable *h*) 211 | (format t "~A: ~A~%" year hero)) 212 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 213 | 214 | 215 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 216 | (defparameter *h* (make-hash-table)) 217 | (setf (gethash "Batman" *h*) "Gotham City") 218 | (gethash "Batman" *h*) 219 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 220 | 221 | 222 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 223 | (defparameter *h* (make-hash-table :test 'equal)) 224 | (setf (gethash "Batman" *h*) "Gotham City") 225 | (gethash "Batman" *h*) 226 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 227 | 228 | 229 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 230 | (defparameter *h* (make-hash-table :test 'equal)) 231 | (loop for (key value) in '(("Superman" 1938) 232 | ("Donald Duck" 1934) 233 | ("Batman" 1939)) do 234 | (setf (gethash key *h*) value)) 235 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 236 | 237 | 238 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 239 | (setf (gethash "Daisy Duck" *h*) 1940) 240 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 241 | 242 | 243 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 244 | (defparameter *h* (make-hash-table)) 245 | (hash-table-count *h*) 246 | (time (loop for n below 1000000 do (setf (gethash n *h*) n))) 247 | (hash-table-count *h*) 248 | (clrhash *h*) 249 | (hash-table-count *h*) 250 | (time (loop for n below 1000000 do (setf (gethash n *h*) n))) 251 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 252 | 253 | 254 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 255 | (defparameter *h* (make-hash-table)) 256 | (hash-table-count *h*) 257 | (hash-table-size *h*) 258 | (hash-table-rehash-size *h*) 259 | (hash-table-rehash-threshold *h*) 260 | (time (loop for n below 1000000 do (setf (gethash n *h*) n))) 261 | (hash-table-count *h*) 262 | (hash-table-size *h*) 263 | (clrhash *h*) 264 | (hash-table-count *h*) 265 | (hash-table-size *h*) 266 | (time (loop for n below 1000000 do (setf (gethash n *h*) n))) 267 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 268 | 269 | 270 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 271 | (defparameter *h* (make-hash-table :size 1000000)) 272 | (time (loop for n below 1000000 do (setf (gethash n *h*) n))) 273 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 274 | 275 | 276 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 277 | (defclass worker () 278 | ((id :initarg :id))) 279 | 280 | (defparameter *workers* ()) 281 | 282 | (defparameter *buffer-hash* (make-hash-table)) 283 | 284 | (defun add-worker (id &optional with-buffer-p) 285 | (let ((new-worker (make-instance 'worker :id id))) 286 | (push new-worker *workers*) 287 | (when with-buffer-p 288 | (setf (gethash new-worker *buffer-hash*) 289 | (make-array 1024))) 290 | new-worker)) 291 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 292 | 293 | 294 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 295 | (dotimes (i 10) 296 | (add-worker i (oddp i))) 297 | (list (length *workers*) 298 | (hash-table-count *buffer-hash*)) 299 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 300 | 301 | 302 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 303 | (pop *workers*) 304 | (list (length *workers*) 305 | (hash-table-count *buffer-hash*)) 306 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 307 | 308 | 309 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 310 | (defparameter *buffer-hash* (make-hash-table :weak-kind :key)) 311 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 312 | 313 | 314 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 315 | (list (length *workers*) 316 | (hash-table-count *buffer-hash*)) 317 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 318 | 319 | 320 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 321 | (defparameter *a* (list (cons 'superman 'metropolis) 322 | (cons 'batman 'gotham-city))) 323 | (assoc 'batman *a*) 324 | (cdr (assoc 'batman *a*)) 325 | (assoc 'donald-duck *a*) 326 | (push (cons 'donald-duck 'duckburg) *a*) 327 | (assoc 'donald-duck *a*) 328 | (push (cons 'donald-duck 'entenhausen) *a*) 329 | (assoc 'donald-duck *a*) 330 | (progn (pop *a*) (pop *a*) *a*) 331 | (setf *a* (acons 'donald-duck 'entenhausen *a*)) 332 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 333 | 334 | 335 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 336 | (assoc "Batman" '(("Superman" . "Metropolis") 337 | ("Batman" . "Gotham City"))) 338 | (assoc "Batman" '(("Superman" . "Metropolis") 339 | ("Batman" . "Gotham City")) 340 | :test 'string=) 341 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 342 | 343 | 344 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 345 | (assoc "batman" '(("Superman" . "Metropolis") 346 | ("Batman" . "Gotham City")) 347 | :test 'string=) 348 | (assoc "batman" '(("Superman" . "Metropolis") 349 | ("Batman" . "Gotham City")) 350 | :test 'string= 351 | :key 'string-downcase) 352 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 353 | 354 | 355 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 356 | (assoc-if 'oddp '((2 . "two") 357 | (4 . "four") 358 | (3 . "three") 359 | (5 . "five"))) 360 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 361 | 362 | 363 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 364 | (setf *a* (cons (cons 'lois-lane 'metropolis) *a*)) 365 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 366 | 367 | 368 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 369 | (pairlis (list "Batman" "Superman" "Donald Duck") 370 | (list "Gotham City" "Metropolis" "Duckburg")) 371 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 372 | 373 | 374 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 375 | (rassoc "Metropolis" '(("Superman" . "Metropolis") 376 | ("Batman" . "Gotham City")) 377 | :test 'string=) 378 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 379 | 380 | 381 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 382 | (setf (cdr (assoc 'batman *a*)) 'new-york-city) 383 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 384 | 385 | 386 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 387 | (setf (cdr (assoc 'spider-man *a*)) 'new-york-city) 388 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 389 | 390 | 391 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 392 | (setf (sys:cdr-assoc 'spider-man *a*) 'new-york-city) 393 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 394 | 395 | 396 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 397 | (defparameter *l* (list 'superman 'metropolis 'batman 'gotham-city)) 398 | (getf *l* 'batman) 399 | (getf *l* 'donald-duck) 400 | (getf *l* 'donald-duck 'nirvana) 401 | (setf *l* (list* 'donald-duck 'duckburg *l*)) 402 | (getf *l* 'donald-duck) 403 | (setf *l* (list* 'donald-duck 'entenhausen *l*)) 404 | (getf *l* 'donald-duck) 405 | (remf *l* 'donald-duck) 406 | *l* 407 | (setf (getf *l* 'donald-duck) 'entenhausen) 408 | *l* 409 | (get-properties *l* '(batman superman)) 410 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 411 | 412 | 413 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 414 | (defparameter *l* 415 | (loop for symbol in '(:a :b :c :d :e :f :g :h :i :j :k) 416 | ;; use ASCII code of symbol's character as value 417 | for code = (char-code (char (symbol-name symbol) 0)) 418 | collect symbol 419 | collect code)) 420 | *l* 421 | (let ((plist *l*) key value) 422 | (loop 423 | (multiple-value-setq (key value plist) 424 | (get-properties plist '(:f :j :a))) 425 | ;; leave loop if nothing was found 426 | (unless key (return)) 427 | ;; skip key/value pair which was found 428 | (setf plist (cddr plist)) 429 | ;; do something with the data 430 | (print (list key value)))) 431 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 432 | 433 | 434 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 435 | ;; primes below 24 436 | (defparameter *p* (list 2 3 5 7 11 13 17 19 23)) 437 | ;; odd numbers below 24 438 | (defparameter *o* (list 1 3 5 7 9 11 13 15 17 19 21 23)) 439 | (union *p* *o*) 440 | (intersection *p* *o*) 441 | (set-difference *p* *o*) 442 | (set-difference *o* *p*) 443 | (set-exclusive-or *p* *o*) 444 | (subsetp *o* *p*) 445 | (subsetp '(11 23) *p*) 446 | (adjoin 2 *p*) 447 | (adjoin 29 *p*) 448 | (member 29 *p*) 449 | (member 17 *p*) 450 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 451 | 452 | 453 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 454 | (set-difference '("Groucho" "Chico" "Harpo") '("Groucho")) 455 | (set-difference '("Groucho" "Chico" "Harpo") '("Groucho") 456 | :test 'string=) 457 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 458 | 459 | 460 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 461 | (defun set-equal (a b) 462 | (null (set-exclusive-or a b))) 463 | (set-equal '(1 2 2 3) '(3 3 1 1 2)) 464 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 465 | 466 | 467 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 468 | (defun hash-set-union (a b) 469 | (let ((result (make-hash-table))) 470 | (loop for key being the hash-keys of a 471 | do (setf (gethash key result) t)) 472 | (loop for key being the hash-keys of b 473 | do (setf (gethash key result) t)) 474 | result)) 475 | 476 | (defun hash-set-intersection (a b) 477 | (let ((result (make-hash-table))) 478 | (loop for key being the hash-keys of a 479 | when (gethash key b) 480 | do (setf (gethash key result) t)) 481 | result)) 482 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 483 | 484 | 485 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 486 | ;; *A* is the set {0,1,3} 487 | (defparameter *a* #b1011) 488 | ;; *B* is the set {0,3,4} 489 | (defparameter *b* #b11001) 490 | (setf *print-base* 2) 491 | ;; union 492 | (logior *a* *b*) 493 | ;; intersection 494 | (logand *a* *b*) 495 | ;; remove element 1 from set *A* 496 | (setf (ldb (byte 1 1) *a*) 0) 497 | *a* 498 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 499 | -------------------------------------------------------------------------------- /code/chapter-17/code.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. 2 | 3 | ;;; This is example code for the book "Common Lisp Recipes" and meant 4 | ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. 5 | ;;; See the book for more information. 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) 9 | 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | (defun sum (n) 13 | (loop for i from 1 to n 14 | sum i)) 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | (defun sum (n) 20 | (* 1/2 n (1+ n))) 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | ;; see file "foo.lisp" in this directory 26 | (time (foo:main 40)) 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | (profile "FOO") 32 | (profile) 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | 35 | 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | (profile foo::foo-3 foo::bar-2 foo::foo-1 foo::foo-2 38 | foo::baz-1 foo::baz-2 foo::bar-1 foo:main) 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | 41 | 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | (foo:main 40) 44 | (report) 45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 46 | 47 | 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | (unprofile "FOO") 50 | (profile) 51 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | 53 | 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | (require :sb-sprof) 56 | (sb-sprof:with-profiling (:report :flat) 57 | (foo:main 40)) 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | 60 | 61 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | (in-package :cl-user) 63 | 64 | (defvar *l* 65 | (loop repeat 10000000 66 | collect (random 1d0))) 67 | 68 | (defun test-1 () 69 | (let ((result 0)) 70 | (map nil (lambda (x) 71 | (incf result (* 2d0 x))) *l*) 72 | result)) 73 | 74 | (defun test-2 () 75 | (declare (optimize speed)) 76 | (let ((result 0)) 77 | (map nil (lambda (x) 78 | (incf result (* 2d0 x))) *l*) 79 | result)) 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | 82 | 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | (time (test-1)) 85 | (time (test-2)) 86 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 87 | 88 | 89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | (time (test-1)) 91 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 92 | 93 | 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | (in-package :cl-user) 96 | 97 | (defconstant +max+ 10000000) 98 | 99 | (defvar *a* 100 | (make-array +max+ :initial-contents (loop repeat +max+ 101 | collect (random 1d0)))) 102 | 103 | (defun test-1 (max) 104 | (loop for i below max 105 | sum (aref *a* i))) 106 | 107 | (defun test-2 (max) 108 | (declare (optimize (safety 0))) 109 | (loop for i below max 110 | sum (aref *a* i))) 111 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 112 | 113 | 114 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 115 | (defun array-sum (array) 116 | (loop for i below (length array) 117 | sum (aref array i))) 118 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 119 | 120 | 121 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 122 | (defun array-sum (array) 123 | (declare (optimize speed)) ; <-- THIS LINE WAS ADDED 124 | (loop for i below (length array) 125 | sum (aref array i))) 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | 128 | 129 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 130 | (defun array-sum (array) 131 | (declare (:explain :types)) ;; <- for LispWorks or AllegroCL 132 | (loop for i below (length array) 133 | sum (aref array i))) 134 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 135 | 136 | 137 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 138 | (defun foo-1 (x) 139 | (let ((result 0)) 140 | (dotimes (i 100000000) 141 | (incf result x)) 142 | result)) 143 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 144 | 145 | 146 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | (defun foo-2 (x) 148 | (declare (double-float x)) ;; <-- ADDED 149 | (let ((result 0d0)) ;; <-- CHANGED 150 | (dotimes (i 100000000) 151 | (incf result x)) 152 | result)) 153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 154 | 155 | 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | (defun foo-3 (x) 158 | (declare (optimize speed) ;; <-- ADDED 159 | (double-float x)) 160 | (let ((result 0d0)) 161 | (dotimes (i 100000000) 162 | (incf result x)) 163 | result)) 164 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 165 | 166 | 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | (defun foo-4 (x) 169 | (declare (optimize speed) 170 | (double-float x)) 171 | (let ((result 0d0)) 172 | (declare (double-float result)) ;; <-- ADDED 173 | (dotimes (i 100000000) 174 | (incf result x)) 175 | result)) 176 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 177 | 178 | 179 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 180 | (foo-4 42) 181 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 182 | 183 | 184 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 185 | (defun foo-5 (x) 186 | (declare (optimize speed (safety 0)) ;; <-- ADDED 187 | (double-float x)) 188 | (let ((result 0d0)) 189 | (declare (double-float result)) 190 | (dotimes (i 100000000) 191 | (incf result x)) 192 | result)) 193 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 194 | 195 | 196 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 197 | (foo-5 42) 198 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 199 | 200 | 201 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 202 | (defun matching-p (edges) 203 | (let ((hash (make-hash-table))) 204 | (loop for (vertex-1 vertex-2) in edges 205 | when (or (gethash vertex-1 hash) 206 | (gethash vertex-2 hash)) 207 | do (return-from matching-p nil) 208 | else do (setf (gethash vertex-1 hash) t 209 | (gethash vertex-2 hash) t)) 210 | t)) 211 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 212 | 213 | 214 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 215 | (defparameter *edges* 216 | (cons (list 99999 100000) 217 | (loop for i below 100000 by 2 218 | collect (list i (1+ i))))) 219 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 220 | 221 | 222 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 223 | (let ((hash (make-hash-table))) ;; <-- now outside of the function 224 | (defun matching-p (edges) 225 | ;; the following initialization loop is new 226 | (loop for vertex being the hash-keys of hash 227 | do (setf (gethash vertex hash) nil)) 228 | ;; the rest is exactly as above 229 | (loop for (vertex-1 vertex-2) in edges 230 | when (or (gethash vertex-1 hash) 231 | (gethash vertex-2 hash)) 232 | do (return-from matching-p nil) 233 | else do (setf (gethash vertex-1 hash) t 234 | (gethash vertex-2 hash) t)) 235 | t)) 236 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 237 | 238 | 239 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 240 | (defparameter *l* (loop for i below 20 collect i)) 241 | 242 | (defun foo-1 (list n) 243 | (let ((dummy list)) 244 | (dotimes (i n) 245 | (setf dummy (reverse dummy))) 246 | dummy)) 247 | 248 | (defun foo-2 (list n) 249 | (let ((dummy list)) 250 | (dotimes (i n) 251 | (setf dummy (nreverse dummy))) ;; <-- note the "N" here 252 | dummy)) 253 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 254 | 255 | 256 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 257 | *l* 258 | (time (foo-1 *l* 99999999)) 259 | *l* 260 | (time (foo-2 *l* 99999999)) 261 | *l* 262 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 263 | 264 | 265 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 266 | (nreverse *l*) 267 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 268 | 269 | 270 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 271 | (setf *l* (nreverse *l*)) 272 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 273 | 274 | 275 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 276 | (loop for i below 100000 sum (/ 1 (expt 1.0001d0 i))) 277 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 278 | 279 | 280 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 281 | (defun do-something (pair) 282 | (+ (first pair) (* 2 (second pair)))) 283 | 284 | (defun foo (list-1 list-2) 285 | (loop for a in list-1 286 | for b in list-2 287 | sum (do-something (list a b)))) 288 | 289 | ;; does the same as FOO 290 | (defun bar (list-1 list-2) 291 | (loop for a in list-1 292 | for b in list-2 293 | sum (let ((x (list a b))) 294 | (declare (dynamic-extent x)) 295 | (do-something x)))) 296 | 297 | ;; random test data 298 | (defvar *l-1* (loop for i below 1000000 299 | collect (random 100))) 300 | 301 | (defvar *l-2* (loop for i below 1000000 302 | collect (random 100))) 303 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 304 | 305 | 306 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 307 | (time (foo *l-1* *l-2*)) 308 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 309 | 310 | 311 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 312 | (time (bar *l-1* *l-2*)) 313 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 314 | 315 | 316 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 317 | (defun three-1 () 318 | (list (random 100) 319 | (random 100) 320 | (random 100))) 321 | 322 | (defun three-2 () 323 | (values (random 100) 324 | (random 100) 325 | (random 100))) 326 | 327 | ;; just to make results comparable 328 | (defvar *r* (make-random-state t)) 329 | 330 | (defun test-1 (n) 331 | (setf *random-state* (make-random-state *r*)) 332 | (let ((result 0)) 333 | (dotimes (i n result) 334 | (destructuring-bind (x y z) 335 | (three-1) 336 | (incf result (min x y z)))))) 337 | 338 | (defun test-2 (n) 339 | (setf *random-state* (make-random-state *r*)) 340 | (let ((result 0)) 341 | (dotimes (i n result) 342 | (multiple-value-bind (x y z) 343 | (three-2) 344 | (incf result (min x y z)))))) 345 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 346 | 347 | 348 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 349 | (time (test-1 1000000)) 350 | (time (test-2 1000000)) 351 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 352 | 353 | 354 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 355 | (defun member* (elt list) 356 | (cond ((null list) nil) 357 | ((eql (first list) elt) list) 358 | (t (member* elt (rest list))))) 359 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 360 | 361 | 362 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 363 | (member* 42 (make-list 10000 :initial-element 41)) 364 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 365 | 366 | 367 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 368 | (defun member* (elt list) 369 | (loop for rest on list 370 | when (eql (first rest) elt) 371 | do (return rest))) 372 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 373 | 374 | 375 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 376 | (defmethod apply-transform ((transform number) vector) 377 | (* transform vector)) 378 | 379 | (defmethod apply-transform ((transforms list) vector) 380 | (apply-transform (compound-transform transforms) vector)) 381 | 382 | (defun compound-transform (transforms) 383 | ;; or use REDUCE 384 | (let ((compound-transform 1)) 385 | (dolist (transform transforms) 386 | (setf compound-transform (* transform compound-transform))) 387 | compound-transform)) 388 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 389 | 390 | 391 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 392 | (apply-transform '(1 2 3 4 5) vector) 393 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 394 | 395 | 396 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 397 | (apply-transform 120 vector) 398 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 399 | 400 | 401 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 402 | (define-compiler-macro apply-transform (&whole form &environment env 403 | transform vector) 404 | (cond ((and (constantp transform env) (listp transform)) 405 | `(apply-transform (load-time-value 406 | (compound-transform ,transform)) 407 | ,vector)) 408 | (t form))) 409 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 410 | 411 | 412 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 413 | (trace compound-transform) 414 | (defun foo (vector) 415 | (apply-transform '(1 2 3 4 5) vector)) 416 | (foo 10) 417 | (compile 'foo) 418 | (foo 10) 419 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 420 | 421 | 422 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 423 | (defun fib (n) 424 | (if (<= n 1) 425 | 1 426 | (+ (fib (- n 2)) (fib (- n 1))))) 427 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 428 | 429 | 430 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 431 | (time (fib 42)) 432 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 433 | 434 | 435 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 436 | (let ((hash (make-hash-table))) 437 | (defun fib* (n) 438 | (or (gethash n hash) 439 | (setf (gethash n hash) 440 | ;; below is the original algorithm 441 | (if (<= n 1) 442 | 1 443 | (+ (fib* (- n 2)) (fib* (- n 1)))))))) 444 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 445 | 446 | 447 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 448 | (time (fib* 42)) 449 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 450 | 451 | 452 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 453 | (fare-memoization:memoize 'fib) 454 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 455 | 456 | 457 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 458 | (declaim (inline bar)) ;; <- see (a) in book 459 | (defun bar (i) 460 | (declare (optimize speed) 461 | (double-float i)) 462 | (let ((j (+ i 1d0))) 463 | (sqrt (+ (* i i) (* j j))))) 464 | (declaim (notinline bar)) ;; <- see (b) in book 465 | 466 | (defun foo-1 () 467 | (declare (optimize speed)) 468 | (let ((x 0d0) 469 | (i 1d0)) 470 | (declare (double-float x)) 471 | (loop 472 | (unless (< i 100000000d0) 473 | (return x)) 474 | (incf x (the double-float (bar i))) 475 | (incf i 1d0)))) 476 | 477 | (defun foo-2 () 478 | (declare (optimize speed) 479 | (inline bar)) ;; <- see (c) in book 480 | (let ((x 0d0) 481 | (i 1d0)) 482 | (declare (double-float x)) 483 | (loop 484 | (unless (< i 100000000d0) 485 | (return x)) 486 | (incf x (bar i)) ;; <- one declaration less 487 | (incf i 1d0)))) 488 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 489 | 490 | 491 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 492 | (time (foo-1)) 493 | (time (foo-2)) 494 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 495 | 496 | 497 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 498 | (defun foo-1 () 499 | (flet ((bar (i) 500 | (sqrt (+ (* i i) (* i i))))) 501 | (loop for k below 42 502 | collect (bar k)))) ;; (A) 503 | 504 | (defun foo-2 () 505 | (flet ((bar (i) 506 | (sqrt (+ (* i i) (* i i))))) 507 | (loop for k below 42 508 | collect (+ (bar k) (bar (+ k 1)))))) ;; (B) 509 | 510 | (defun foo-3 () 511 | (flet ((bar (i) 512 | (sqrt (+ (* i i) (* i i))))) 513 | (declare (inline bar)) 514 | (loop for k below 42 515 | collect (+ (bar k) (bar (+ k 1)))))) ;; (C) 516 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 517 | 518 | 519 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 520 | (defun dot-product-1 (x-1 x-2 y-1 y-2) 521 | (+ (* x-1 y-1) (* x-2 y-2))) 522 | 523 | (defun dot-product-2 (x-1 x-2 y-1 y-2) 524 | (declare (optimize (safety 2) 525 | (hcl:fixnum-safety 0))) 526 | (+ (* x-1 y-1) (* x-2 y-2))) 527 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 528 | 529 | 530 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 531 | (disassemble 'dot-product-1) 532 | (disassemble 'dot-product-2) 533 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 534 | 535 | 536 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 537 | (defconstant +max+ 10000000) 538 | 539 | (defvar *a* 540 | (let ((a (make-array +max+ :element-type 'double-float))) 541 | (dotimes (i +max+) 542 | (setf (aref a i) (random 1d0))) 543 | a)) 544 | 545 | (defun foo-1 (a) 546 | (let ((result 1d0)) 547 | (declare (double-float result)) 548 | (dotimes (i +max+) 549 | (incf result (the double-float (aref a i)))) 550 | result)) 551 | 552 | (defun foo-2 (a) 553 | (declare (type (simple-array double-float (*)) a)) 554 | (let ((result 1d0)) 555 | (declare (double-float result)) 556 | (dotimes (i +max+) 557 | (incf result (aref a i))) 558 | result)) 559 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 560 | 561 | 562 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 563 | (time (foo-1 *a*)) 564 | (time (foo-2 *a*)) 565 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 566 | --------------------------------------------------------------------------------