* Chapter-01 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-01/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :p1 (:intern :alpha) (:use :cl) (:export :bravo :charlie)) (defpackage :p2 (:intern :alpha :delta) (:use :p1) (:export :bravo :echo)) (defpackage :p3 (:intern :alpha) (:use :p2 :cl) (:export :charlie) (:import-from :p2 :delta)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (import 'p2::alpha :p3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro swap (var-1 var-2) `(let ((temp ,var-1)) (setf ,var-1 ,var-2 ,var-2 temp) (values))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *a* 42) (defparameter *b* 23) (swap *a* *b*) (list *a* *b*) (defparameter temp 100) (swap temp *a*) (list temp *a*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((temp temp)) (setf temp *a* ,*a* temp) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro swap (var-1 var-2) `(let ((my-own-temp-var-name-please-do-not-use ,var-1)) (setf ,var-1 ,var-2 ,var-2 my-own-temp-var-name-please-do-not-use) (values))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro swap (var-1 var-2) (let ((temp-var (gensym))) ;; <- added `(let ((,temp-var ,var-1)) ;; <- changed (setf ,var-1 ,var-2 ,var-2 ,temp-var) ;; <- changed (values)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (macroexpand '(swap *a* *b*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-symbol "FOO") (make-symbol "FOO") (eql * **) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro swap (var-1 var-2) `(let ((#:temp ,var-1)) (setf ,var-1 ,var-2 ,var-2 #:temp) (values))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro swap (var-1 var-2) (let ((temp '#:temp)) `(let ((,temp ,var-1)) (setf ,var-1 ,var-2 ,var-2 ,temp) (values)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun test () 42) (defparameter *s* 'test) ;; or (DEFPARAMETER *S* *) instead (test) (unintern 'test) (test) (funcall *s*) ;; or (#.*s*) instead ,*s* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval-when (:execute) 42) (unintern :execute :keyword) (eval-when (:execute) 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (symbol-function 'test) (symbol-function *s*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (unintern 'test) (import *s*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :bio (:use :cl)) (in-package :bio) (defclass tree () ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :graph (:use :cl) (:export :vertex :edge :tree)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (use-package :graph) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (shadow 'tree) (use-package :graph) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :bio (:use :cl)) (in-package :bio) (defclass tree () ()) (find-class 'tree nil) (defpackage :graph (:use :cl) (:export :vertex :edge :tree)) (shadowing-import 'graph:tree) (use-package :graph) (find-class 'tree nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :graph (:export :node :vertex :tree)) (defpackage :bio (:export :cat :dog :tree)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (shadowing-import 'graph:tree) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (shadowing-import 'bio:tree) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :foo (:export :quux)) (defpackage :bar (:use :foo) (:export :quux)) (eql 'foo:quux 'bar:quux) (use-package '(:foo :bar)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *pics-dir* #p"/data/pictures/") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (merge-pathnames "nanook.jpg" *pics-dir*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-symbol-macro %pics-dir% (resource-information :type :directory :data :images)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro pics-dir () '(resource-information :type :directory :data :images)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (merge-pathnames "nanook.jpg" (pics-dir)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((%pics-dir% #p"/tmp/")) (merge-pathnames "nanook.jpg" %pics-dir%)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (find-symbol "FOO") 'foo (find-symbol "FOO") 'bar (export *) (defpackage :quux (:use :cl)) (in-package :quux) (find-symbol "FOO") (find-symbol "BAR") (use-package :cl-user) (find-symbol "FOO") (find-symbol "BAR") (find-all-symbols "FOO") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (union (find-all-symbols "VECTOR-ADD") (find-all-symbols "VECTOR-MULT")) (let (result) (do-all-symbols (s) (when (member s '("VECTOR-ADD" "VECTOR-MULT") :test 'string=) (pushnew s result))) result) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for s being each external-symbol of :cl count s) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :quux (:use :cl)) (in-package :quux) (loop for s being each present-symbol collect s) (loop for s being each symbol of (find-package "QUUX") count t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (do-symbols (s ':cl) (when (eql (char (symbol-name s) 0) #\Y) (return s))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (readtable-case *readtable*) (symbol-name :foo) (symbol-name :FOO) (symbol-name :Foo) (symbol-name :F\oo) (setf (readtable-case *readtable*) :preserve) (SYMBOL-NAME :foo) (SYMBOL-NAME :FOO) (SYMBOL-NAME :Foo) (SYMBOL-NAME :F\oo) (SETF (READTABLE-CASE *READTABLE*) :DOWNCASE) (|SYMBOL-NAME| :foo) (|SYMBOL-NAME| :FOO) (|SYMBOL-NAME| :Foo) (|SYMBOL-NAME| :\Foo) (|SETF| (|READTABLE-CASE| |*READTABLE*|) :|INVERT|) (symbol-name :foo) (symbol-name :FOO) (symbol-name :Foo) (symbol-name :f\oo) (setf (readtable-case *readtable*) :upcase) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (readtable-case *readtable*) (symbol-name :foo) :foo (symbol-name :|foo|) :|foo| ,*print-case* (setf *print-case* :downcase) :foo :|foo| (setf *print-case* :capitalize) :foo :|foo| (setf *print-case* :upcase) (setf (readtable-case *readtable*) :downcase) (|LIST| :foo :|FOO|) (|SETF| |*PRINT-CASE*| :|DOWNCASE|) (|LIST| :foo :|FOO|) (|SETF| |*PRINT-CASE*| :|CAPITALIZE|) (|LIST| :foo :|FOO|) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (length (remove-duplicates (mapcar #'find-package '(CL :CL #:CL "CL")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (string-capitalize :foo) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (find-package "cl") (find-package '|cl|) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :my-package-1 (:use :cl) (:export :important-function)) ;; ... or ... (defpackage #:my-package-2 (:use #:cl) (:export #:important-function)) ;; ... or ... (defpackage "MY-PACKAGE-3" (:use "CL") (:export "IMPORTANT-FUNCTION")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :vec (:use :cl) (:shadow :vector :+)) (in-package :vec) (defclass vector () ((x :initarg :x :reader x) (y :initarg :y :reader y))) (defgeneric + (arg &rest other-args) (:method ((arg number) &rest other-args) (apply 'cl:+ arg other-args))) (defmethod + ((arg vector) &rest other-args) (make-instance 'vector :x (apply 'cl:+ (x arg) (mapcar 'x other-args)) :y (apply 'cl:+ (y arg) (mapcar 'y other-args)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (+ 3 4 5) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (+ (make-instance 'vector :x 3 :y 4) (make-instance 'vector :x 5 :y 6) (make-instance 'vector :x 7 :y 8)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-02 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-02/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cons 42 #\X) (car *) (cdr **) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cons 'foo 'bar) '(foo . bar) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cons (make-array 1 :initial-element 23) "23") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cons (cons 1 2) :foo) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cons 'a (cons 'b (cons 'c (cons 'd nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cons 1 (cons 3 4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cons 42 nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; nil (cons 1 2) (cons (cons 1 2) 3) (cons (cons (cons 1 2) 3) 4) (cons 1 (cons 2 (cons 3 4))) (cons 1 (cons 2 (cons 3 nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (list 1 2 3) (list 1) (list) (list 1 2 (list 3 4)) (list* 1 2 (list 3 4)) (make-list 4 :initial-element 42) (make-list 4) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (coerce #(3 2 1 0) 'list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (map 'list 'identity #(3 2 1 0)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (coerce "Frunobulax" 'list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun integer-to-bit-list (x) (check-type x (integer 0 *)) (reverse (map 'list 'digit-char-p (write-to-string x :base 2)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun integer-to-bit-list (x) (check-type x (integer 0 *)) (let (result) (loop (when (zerop x) (return (nreverse result))) (push (logand x 1) result) (setf x (ash x -1))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *m* '((11 12 13 14) (21 22 23 24) (31 32 33 34))) (let ((*print-right-margin* 20)) (pprint (apply 'mapcar 'list *m*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mapcar 'list '(11 12 13 14) '(21 22 23 24) '(31 32 33 34)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; `(a b c) '(a b c) (quote (a b c)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((b 42)) `(a ,b c)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((b (list 23 42))) `(a ,@b c)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((x 'f) (y (list 'g nil nil))) `(a (b (d nil nil) (e nil nil)) (c (,x nil nil) (,@y)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((list '(3 4))) `(1 2 . ,list)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((list '(3 4))) `#(1 2 ,@list 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (flet ((foo (x) `(,x b c))) (let ((a (foo 23)) (b (foo 42))) (list a b (eq a b) (eq (cdr a) (cdr b))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *list* (list 'a 'b 'c)) (setf *list* (append *list* (list 'd))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let (list) (dotimes (i 10) (setf list (append list (list (* i i))))) list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let (list) (dotimes (i 10) (push (* i i) list)) (nreverse list)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *list* (list 'a 'b 'c 'd)) (defparameter *tail* (cdddr *list*)) ;; or (LAST *LIST*) ,*tail* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (setf (cdr *tail*) (cons 'e 'nil) ,*tail* (cdr *tail*)) ,*list* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let (list tail) (dotimes (i 10) (let ((new-tail (cons (* i i) nil))) (cond ((null list) (setf list new-tail)) (t (setf (cdr tail) new-tail))) (setf tail new-tail))) list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for i below 10 collect (* i i)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *list* (list 1 2 3 42 5)) (nth 3 *list*) (setf (nth 3 *list*) 4) ,*list* (subseq *list* 2 4) (setf (subseq *list* 2 4) (list :three :four)) ,*list* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *new* (list 'x 'y 'z)) (setf *list* (splice *list* :start 1 :end 3 :new *new*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun splice (list &key (start 0) (end (length list)) new) (setf list (cons nil list)) ;; add dummy cell (let ((reroute-start (nthcdr start list))) (setf (cdr reroute-start) (nconc (make-list (length new)) ;; empty cons cells (nthcdr (- end start) ;; tail of old list (cdr reroute-start))) list (cdr list))) ;; remove dummy cell (replace list new :start1 start) ;; fill empty cells list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *list* (list 'a 'b 'c 'd 'e)) (defparameter *new* (list 'x 'y 'z)) (setf *list* (splice *list* :start 1 :end 3 :new *new*)) ,*new* (splice *list* :start 1 :end 4) (splice *list* :start 2 :new (list 1 2 3)) (splice *list* :start 3 :end 3 :new (list 42)) ,*list* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *list* (list 'a 'b 'c 'd 'e)) (splice *list* :end 3 :new (list 1 2 3)) ,*list* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *a* (list :a :b :c :d :e)) (defparameter *b* (list :b :c :d :e)) (list *a* *b*) (tailp *b* *a*) (tailp (cdr *b*) *a*) (let ((tail (list :c :d :e))) (setf *a* (append (list :a :b) tail) ,*b* (cons :b tail))) (list *a* *b*) (eql *a* *b*) (tailp *b* *a*) (tailp (cdr *b*) *a*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (tailp nil '(1 2 3)) ;; NIL is a tail of every proper list (tailp 42 '(1 2 . 42)) ;; TAILP accepts dotted lists ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-tailp (object list) (check-type list list) (loop for tail = list then (cdr tail) until (prog1 (atom tail) (when (eql object tail) (return t))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (tailp (cdr *b*) *a*) (ldiff *a* (cdr *b*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *a* '(42 "3" 5.3 :x #\u :a 23/12)) (ldiff *a* (member-if 'symbolp *a*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cons (cons 'A 'B) (cons 'C 'D)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun node-value (node) (car node)) ;; or (FIRST NODE) (defun left-child (node) (cadr node)) ;; or (SECOND NODE) (defun right-child (node) (caddr node)) ;; or (THIRD NODE) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun make-node (&key value left-child right-child) (list value left-child right-child)) (defun (setf node-value) (new-value node) (setf (car node) new-value)) (defun (setf left-child) (new-child node) (setf (cadr node) new-child)) (defun (setf right-child) (new-child node) (setf (caddr node) new-child)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((tree (make-node :value 'a))) (setf (left-child tree) (make-node :value 'b :left-child (make-node :value 'd) :right-child (make-node :value 'e)) (right-child tree) (make-node :value 'c :left-child (make-node :value 'f) :right-child (make-node :value 'g))) tree) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ql:system-apropos "tree") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *stack* nil) (push :plate *stack*) (push :another-plate *stack*) (pop *stack*) ,*stack* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass queue () ((list :initform nil) (tail :initform nil))) (defmethod print-object ((queue queue) stream) (print-unreadable-object (queue stream :type t) (with-slots (list tail) queue (cond ((cddddr list) ;; at least five elements, so print ellipsis (format stream "(~{~S ~}... ~S)" (subseq list 0 3) (first tail))) ;; otherwise print whole list (t (format stream "~:S" list)))))) (defmethod dequeue ((queue queue)) (with-slots (list) queue (pop list))) (defmethod enqueue (new-item (queue queue)) (with-slots (list tail) queue (let ((new-tail (list new-item))) (cond ((null list) (setf list new-tail)) (t (setf (cdr tail) new-tail))) (setf tail new-tail))) queue) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *q* (make-instance 'queue)) ,*q* (enqueue 42 *q*) (enqueue :foo *q*) (dotimes (i 5 *q*) (enqueue i *q*)) (dequeue *q*) ,*q* (dequeue *q*) ,*q* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (destructuring-bind (a (b &rest c) (d (e . f))) '("A" (:b 2 3) (#\D (1.0 . 3.0))) (list a b c d e f)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (destructuring-bind (&key a (b :not-found) c &allow-other-keys) '(:c 23 :d "D" :a #\A :foo :whatever) (list a b c)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ql:quickload '(:optima :fare-quasiquote-optima :fare-quasiquote-readtable)) (named-readtables:in-readtable :fare-quasiquote) (optima:match (list 42 23) (`(,x ,_ ,_) (list :three x)) (`(,x ,_) (list :two x))) (optima:match (list 42 23) (`(41 ,x) x) (`(,x 23) x)) (optima:match '(1 (2 (3 4 5 6) 7 8) 9) (`(1 (2 (3 ,x) 7 8) 9) (list :one x)) (`(1 (2 (3 ,x . ,_) 7 8) 9) (list :two x))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-03 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-03/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (char-code #\a) (char-code #\A) (char-code #\ü) (char-code #\א) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (code-char 97) (code-char 65) (code-char 252) (code-char 1488) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (char-name #\A) (char-name #\a) (name-char "Latin_Small_Letter_A") #\latin_small_letter_a (char-name (code-char 1488)) #\HEBREW_LETTER_ALEF #\U+05D0 (name-char "U+05D0") (name-char "A") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (write-byte 195 out) (write-byte 156 out)) (with-open-file (out "/tmp/foo.txt" :direction :output :if-exists :append :element-type 'character :external-format :latin-1) (write-string "berjazz" out)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (in "/tmp/foo.txt" :element-type 'character :external-format :utf-8) (read-line in)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (char= #\a #\a) (char= #\a #\b) (char= #\a #\A) (char-equal #\a #\A) (char< #\a #\b) (char< #\A #\b) (char< #\a #\B) (char-lessp #\A #\b) (char-lessp #\a #\B) (eql "foo" "foo") (string= "foo" "foo") (equal "foo" "foo") (string= "foo" "Foo") (equal "foo" "Foo") (string-equal "foo" "Foo") (equalp "foo" "Foo") (string< "adam" "eve") (string< "aardvark" "aardwolf") (string< "werewolf" "aardwolf") (string< "aardvark" "Aardwolf") (string-lessp "aardvark" "Aardwolf") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (both-case-p (code-char #x17F)) (char-equal #\S (code-char #x17F)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "~Cberjazz" #\U+00DC) (let ((foo "Ü")) (format nil "~Aberjazz" foo)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "~Cberjazz" #\U+00DC) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #.(format nil "~Cberjazz" #\U+00DC) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (char-upcase #\a) (char-downcase #\A) (char-downcase #\a) (char-downcase #\Space) (char-downcase #\greek_capital_letter_alpha) (upper-case-p #\A) (lower-case-p #\a) (upper-case-p #\Space) (lower-case-p #\Space) (both-case-p #\Space) (both-case-p #\hebrew_letter_alef) (string-upcase "miles davis") (string-downcase "MILES") (string-capitalize "miles DAVIS") (string-upcase "miles davis" :start 0 :end 6) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((string (copy-seq "Grover Washington, jr."))) (setf (char string 19) (char-upcase (char string 19))) string) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "Downcase: ~(~A~)" "FOO") (format nil "Capitalize: ~:(~A~)" "FOO BAR BAZ") (format nil "Capitalize first word, downcase rest: ~@(~A~)" "FOO BAR BAZ") (format nil "Upcase: ~:@(~A~)" "Foo BAR baz") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (subseq "Cookbook" 4) (subseq "Cookbook" 4 7) (let ((string1 (copy-seq "Harpo Marx")) (string2 (copy-seq "Groucho, Harpo, and Chico"))) (setf (subseq string1 0 5) "Zeppo") (print string1) (setf (subseq string1 0 5) "Groucho") (print string1) (setf string1 (replace string1 string2 :start1 0 :end1 5 :start2 9 :end2 14)) (print string1) (setf (subseq string1 0) "Groucho") string1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((string1 (copy-seq "walk")) (string2 (subseq string1 0))) (setf (char string2 0) #\t) (values string1 string2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (find #\o "We're Only In It For The Money") (find #\o "We're Only In It For The Money" :test 'char-equal) (position #\o "We're Only In It For The Money") (position #\O "We're Only In It For The Money") (search "on" "We're Only In It For The Money") (search "on" "We're Only In It For The Money" :test 'char-equal) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (string-trim '(#\Space #\Linefeed) " This is a sentence. ") (string-left-trim "([" "([foo])") (string-right-trim ")]" *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((string1 (copy-seq "abc")) (string2 (string-trim "x" string1))) (setf (char string2 0) #\A) (list string1 string2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; assumes something like ASCII - see footnote ;; see https://en.wikipedia.org/wiki/Digital_root (defun digital-root (string) (assert (every #'digit-char-p string) (string) "~S doesn't denote a non-negative decimal integer." string) (loop for char across string sum (digit-char-p char) into result finally (return (if (> result 9) (digital-root (princ-to-string result)) result)))) (digital-root "12") (digital-root "1234") ;; assumes something like ASCII - see footnote ;; see https://en.wikipedia.org/wiki/ROT13 (defun rot13-char (char) (cond ((char<= #\a char #\z) (code-char (+ (mod (+ (- (char-code char) (char-code #\a)) 13) 26) (char-code #\a)))) ((char<= #\A char #\Z) (code-char (+ (mod (+ (- (char-code char) (char-code #\A)) 13) 26) (char-code #\A)))))) (map 'string #'rot13-char "foobar") (map 'string #'rot13-char *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((string "frob")) (values (aref string 0) (char string 1) (schar string 2) (subseq string 3 4))) (let ((string "baz")) (loop for i below (length string) collect (char string i))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (coerce "Recipes" 'list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun n-rot13-string (string) (loop for i below (length string) do (setf (char string i) (rot13-char (char string i))))) (defparameter *string* (copy-seq "foobar")) (n-rot13-string *string*) ,*string* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; or like this: (defun n-rot13-string (string) (map-into string 'rot13-char string)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun join (separator list) (with-output-to-string (out) (loop for (element . more) on list do (princ element out) when more do (princ separator out)))) (join #\Space '("This" "is" "it")) (join #\- '(2003 12 31)) (join ", " '("C" "C++" "C#")) (join "" '("Hallo" "ween")) (join #\- '()) (join #\- '("One item only")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun join (separator list) (with-output-to-string (out) (loop (princ (or (pop list) "") out) (unless list (return)) (princ separator out)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun join (separator list) (with-output-to-string (out) (when list (princ (pop list) out)) (loop (unless list (return)) (princ separator out) (princ (pop list) out)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "~{~A~^, ~}" (list "C" "C++" "C#")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun list-join (separator list) (loop for (element . more) on list collect element when more collect separator)) (list-join '+ (loop for i below 5 collect i)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *csv-readtable* (copy-readtable)) (set-syntax-from-char #\, #\Space *csv-readtable*) (defun read-csv-line (string) (let ((*readtable* *csv-readtable*)) (with-input-from-string (stream string) (loop for object = (read stream nil nil) while object collect object)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see separate file "test.tsv" in this directory (with-open-file (stream "/tmp/test.csv") (loop for line = (read-line stream nil nil) while line collect (read-csv-line line))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-04 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-04/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see (defun fermat (n) (1+ (expt 2 (expt 2 n)))) (fermat 7) (fermat 8) (gcd * **) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for n in (list most-positive-fixnum (1+ most-positive-fixnum)) append (loop for type in '(fixnum bignum integer) collect (typep n type))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (1+ (max (integer-length most-positive-fixnum) (integer-length most-negative-fixnum))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mod (* 58 74051161) (expt 2 32)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconstant +mod+ (expt 2 32)) (defun plus (x y) (mod (+ x y) +mod+)) (defun times (x y) (mod (* x y) +mod+)) ;; etc. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconstant +mod+ (expt 2 32)) (defun times-mod (x y) (mod (* x y) +mod+)) (defun times-rem (x y) (rem (* x y) +mod+)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun times-mod (x y) (declare (type (unsigned-byte 32) x y)) (mod (* x y) (expt 2 32))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (list (list #b101010 #o52 #x2A) (loop for fmt in '("~B" "~O" "~X") collect (format nil fmt 42))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for fmt in '("~R" "~:R" "~@R") collect (format nil fmt 42)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; the default values ,*read-base* ,*print-base* ;; switch to binary input (setf *read-base* 2) 101010 ;; you can still override this with # #x2A ;; this does NOT switch back to decimal because "10" is read ;; as a binary number... (setf *read-base* 10) ;; this works (setf *read-base* 1010) ;; now switch to hexadecimal output (setf *print-base* 16) 42 (setf *print-radix* t) 42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (/ 3 4) (floor 3 4) 6/8 (* 3/4 8/3) (+ 1/3 3/7) (/ (expt 2 30) (1+ (expt 3 30))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (denominator (/ 2 -10)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (/ 3 4) (floor (/ 3 4)) (floor 3 4) (floor -3 4) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (dolist (fn '(floor ceiling truncate round)) (dolist (args '((3 4) (-3 4))) (format t "~A -> ~A " (list* fn args) (apply fn args))) (terpri)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for i in '(1/2 3/2 5/2 7/2) collect (round i)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (rational 0.5) (rationalize 0.5) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (rational 0.2) (rationalize 0.2) (list (float *) (float **)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (float 1/7) (float 1/7 1d0) (float 0.1f0 1d0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (* 2f0 2d0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (* 2 2d0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (< 6/7 (float 6/7)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*read-default-float-format* (- 1.00000001 1) 1.00000001 (- 1.00000001d0 1) (setf *read-default-float-format* 'double-float) (- 1.00000001 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*read-default-float-format* 1.0f0 1.0d0 (setf *read-default-float-format* 'double-float) 1.0f0 1.0d0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo (orig &optional (n 10)) (let ((x orig)) (loop repeat n do (setf x (sqrt x))) (loop repeat n do (setf x (* x x))) (list x (* (/ (abs (- x orig)) orig) 100)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (ext:long-float-digits) 256) (foo 2l0 50) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo-r (orig &optional (n 10)) (let ((x orig)) (loop repeat n do (setf x (cr:sqrt-r x))) (loop repeat n do (setf x (cr:*r x x))) x)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cr:sqrt-r 2) (cr:print-r * 30) (cr:print-r ** 40) (cr:print-r *** 50) ;; and so on... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sqrt -1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #C(8 -9) #c(2/4 1/2) #c(2/4 .5) #c(2d0 2f0) (complex 1/2 3) (complex 1 0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (* #c(2.0 3.0) #c(-1.0 2.0)) (sin #c(2.0d0 3.0)) (abs #c(3 -4)) (+ #c(61/2 3) #c(23/2 -3)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (1+ (exp (* pi #c(0 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (parse-integer " 42") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (parse-integer "42 quux") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (parse-integer "42 quux" :junk-allowed t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun parse-integers (string) (let ((start 0) (end (length string)) (result '())) (loop (when (>= start end) (return (nreverse result))) (multiple-value-bind (number pos) (parse-integer string :start start :junk-allowed t) (cond (number (push number result) (setf start pos)) (t (setf start end))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for radix in '(2 8 10 16) collect (parse-integer "111" :radix radix)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (read-from-string "#.(lw:quit)") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for input in '("-42" "2/84" "#c(3 4)" "2.34" "2d3") collect (parse-number:parse-number input)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1.1234567890123456D0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (= 42 42.0) (eql 42 42.0) (= 0.33333333 1/3) (= 0.33333333 11184811/33554432) (eql 0.33333333 11184811/33554432) (= #c(3 0) 3) (eql #c(3 0) 3) (= #c(3.0 0) 3) (eql #c(3.0 0) 3) (= (1+ most-positive-fixnum) (1+ most-positive-fixnum)) (eql (1+ most-positive-fixnum) (1+ most-positive-fixnum)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eq (1+ most-positive-fixnum) (1+ most-positive-fixnum)) (eq 3d0 3d0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (dolist (x '(1 -1)) (dolist (y '(1 -1)) (print (list x y (round (* (/ 180 pi) (atan (/ y x)))) (round (* (/ 180 pi) (atan y x))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-05 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-05/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *hours* (make-array '(365 24))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (aref *hours* 41 2) "foo") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a (make-array '(4 5 6)))) (list (array-total-size a) (array-rank a) (array-dimensions a) (array-dimension a 1))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-array-dimension (array i) (nth i (array-dimensions array))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-array-rank (array) (length (array-dimensions array))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-array-total-size (array) (reduce #'* (array-dimensions array) :initial-value 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a (make-array 10 :fill-pointer 3))) (list (array-total-size a) (length a))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-array '(8 8) :initial-element #\x) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-array '(2 3) :initial-contents '((2 3 5) (7 11 13))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-array '(2 3) :initial-contents '((1 2 3) (4 5 6))) (make-array '(3 2) :initial-contents '((1 2) (3 4) (5 6))) (make-array '(2 3 2) :initial-contents '(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-array '(2 3) :initial-contents '#(#(1 2 3) #(4 5 6))) (make-array '(2 3) :initial-contents '#((1 2 3) (4 5 6))) (make-array '(2 3) :initial-contents '#(#(1 2 3) (4 5 6))) (make-array '(2 3) :initial-contents '((1 2 3) #(4 5 6))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a (make-array '(4 4) :initial-element (list 1 2 3)))) (setf (second (aref a 0 1)) 42) (aref a 2 2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a (make-array '(4 4)))) ;; initialize array (dotimes (i 16) (setf (row-major-aref a i) (list 1 2 3))) ;; now the same test as above (setf (second (aref a 0 1)) 42) (aref a 2 2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a (make-array '(20 10)))) (dotimes (i 20) (dotimes (j 10) (setf (aref a i j) (* i j)))) (list (aref a 6 7) (row-major-aref a 67))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-array '(3 2 4) :initial-contents '((( 2 3 5 7) (11 13 17 19)) ((23 29 31 37) (41 43 47 53)) ((59 61 67 71) (73 79 83 89)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-array '(4 6) :initial-contents '(( 2 3 5 7 11 13) (17 19 23 29 31 37) (41 43 47 53 59 61) (67 71 73 79 83 89))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a (make-array '(5 10 20)))) (dotimes (i 5) (dotimes (j 10) (dotimes (k 20) (setf (aref a i j k) (* i j k))))) (list (aref a 2 3 7) (row-major-aref a (array-row-major-index a 2 3 7)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a (make-array 10 :fill-pointer 3))) (print (length a)) (vector-push 42 a) (print (length a)) (aref a 3)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a (make-array 30 :initial-contents (loop for i below 30 collect i) :fill-pointer 20))) (print (aref a 23)) (find 23 a)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a (make-array 10 :fill-pointer 0))) (print (length a)) (dotimes (i 3) (vector-push (* i i) a)) (list (length a) (vector-pop a) (length a))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun adjust-test (adjustable) (let* ((a (make-array '(4 6) :initial-element 42 :adjustable adjustable)) (b (adjust-array a '(5 5) :initial-element 23))) (list (array-dimensions b) (eq a b) (array-dimensions a) (aref b 1 1) (aref b 4 4)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-adjust-array (old-array new-dimensions &key initial-element) (let ((new-array (make-array new-dimensions :initial-element initial-element)) (copy-dimensions (mapcar #'min new-dimensions (array-dimensions old-array)))) (labels ((copy-elements (indices dimensions) (if dimensions (dotimes (i (first dimensions)) (copy-elements (cons i indices) (rest dimensions))) (setf (apply #'aref new-array (reverse indices)) (apply #'aref old-array (reverse indices)))))) (copy-elements nil copy-dimensions) new-array))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((a (make-array '(5 5))) (b (make-array '(3 6) :displaced-to a :displaced-index-offset 4))) (dotimes (i 5) (dotimes (j 5) (setf (aref a i j) (+ (* 10 (1+ i)) (1+ j))))) (print (list (aref a 3 1) (aref b 2 0))) (setf (aref b 2 0) 23) (aref a 3 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-array '(100 100) :element-type 'double-float) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a (make-array 10 :element-type '(unsigned-byte 3)))) (array-element-type a)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((a (make-array 3 :initial-contents '(1 2 3))) (b (copy-seq a))) (setf (aref b 1) 42) (list a b (eq a b))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun copy-array (array) (let ((dimensions (array-dimensions array))) (adjust-array (make-array dimensions :element-type (array-element-type array) :displaced-to array) dimensions))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((a (make-array 3 :initial-contents (list (list 1 2) 3 4))) (b (copy-seq a))) (setf (nth 1 (aref a 0)) 42) (list a b)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-06 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-06/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table)) (gethash 'batman *h*) (setf (gethash 'batman *h*) 'gotham-city) (gethash 'batman *h*) (setf (gethash 'superman *h*) 'duckburg) (gethash 'superman *h*) (setf (gethash 'superman *h*) 'metropolis) (gethash 'superman *h*) (gethash 'spider-man *h*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (gethash 'lois-lane *h*) 'metropolis) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table)) (gethash 'batman *h*) (setf (gethash 'batman *h*) nil) (gethash 'batman *h*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table)) (setf (gethash 'gladstone-gander *h*) 'goose) (setf (gethash 'gyro-gearloose *h*) 'chicken) (defun duckburg-species (name) (gethash name *h*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (duckburg-species 'gyro-gearloose) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun duckburg-species (name) (gethash name *h* 'duck)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (duckburg-species 'gyro-gearloose) (duckburg-species 'donald-duck) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun duckburg-species (name) (or (gethash name *h*) 'duck)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table)) (setf (gethash 'batman *h*) 'gotham-city) (setf (gethash 'superman *h*) 'metropolis) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (gethash 'superman *h*) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (remhash 'superman *h*) (gethash 'superman *h*) (hash-table-count *h*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table)) (loop for (key value) in '((superman 1938) (donald-duck 1934) (batman 1939)) do (setf (gethash key *h*) value)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((min 2015) oldest) (maphash (lambda (hero year) (when (< year min) (setf min year oldest hero))) ,*h*) oldest) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((min 2015) oldest) (with-hash-table-iterator (next-hero *h*) (loop (multiple-value-bind (not-done hero year) (next-hero) (unless not-done (return oldest)) (when (< year min) (setf min year oldest hero)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-maphash (function hash-table) (with-hash-table-iterator (next-entry hash-table) (loop (multiple-value-bind (more key value) (next-entry) (unless more (return nil)) (funcall function key value))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun hero-from (this-year) (with-hash-table-iterator (next-hero *h*) (loop (multiple-value-bind (not-done hero year) (next-hero) (unless not-done (return nil)) (when (= year this-year) ;; skip the rest, we're done (return hero)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with min = 2015 and oldest for hero being the hash-keys of *h* using (hash-value year) when (< year min) do (setf min year oldest hero) finally (return oldest)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with min = 2015 and oldest for year being the hash-values of *h* using (hash-key hero) when (< year min) do (setf min year oldest hero) finally (return oldest)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for hero being the hash-keys of *h* collect hero) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for hero being the hash-keys of *h* using (hash-value year) when (< year 1935) do (remhash hero *h*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; don't do that! (loop for hero being the hash-keys of *h* using (hash-value year) when (eql hero 'batman) do (setf (gethash 'robin *h*) (1+ year))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro dohash ((key-name value-name hash-table) &body body) (let ((next (gensym "NEXT")) (more (gensym "MORE"))) `(with-hash-table-iterator (,next ,hash-table) (loop (multiple-value-bind (,more ,key-name ,value-name) (,next) (unless ,more (return nil)) ,@body))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (dohash (hero year *h*) (format t "~A: ~A~%" year hero)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (iter (for (hero year) in-hashtable *h*) (format t "~A: ~A~%" year hero)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table)) (setf (gethash "Batman" *h*) "Gotham City") (gethash "Batman" *h*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table :test 'equal)) (setf (gethash "Batman" *h*) "Gotham City") (gethash "Batman" *h*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table :test 'equal)) (loop for (key value) in '(("Superman" 1938) ("Donald Duck" 1934) ("Batman" 1939)) do (setf (gethash key *h*) value)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (gethash "Daisy Duck" *h*) 1940) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table)) (hash-table-count *h*) (time (loop for n below 1000000 do (setf (gethash n *h*) n))) (hash-table-count *h*) (clrhash *h*) (hash-table-count *h*) (time (loop for n below 1000000 do (setf (gethash n *h*) n))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table)) (hash-table-count *h*) (hash-table-size *h*) (hash-table-rehash-size *h*) (hash-table-rehash-threshold *h*) (time (loop for n below 1000000 do (setf (gethash n *h*) n))) (hash-table-count *h*) (hash-table-size *h*) (clrhash *h*) (hash-table-count *h*) (hash-table-size *h*) (time (loop for n below 1000000 do (setf (gethash n *h*) n))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table :size 1000000)) (time (loop for n below 1000000 do (setf (gethash n *h*) n))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass worker () ((id :initarg :id))) (defparameter *workers* ()) (defparameter *buffer-hash* (make-hash-table)) (defun add-worker (id &optional with-buffer-p) (let ((new-worker (make-instance 'worker :id id))) (push new-worker *workers*) (when with-buffer-p (setf (gethash new-worker *buffer-hash*) (make-array 1024))) new-worker)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (dotimes (i 10) (add-worker i (oddp i))) (list (length *workers*) (hash-table-count *buffer-hash*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (pop *workers*) (list (length *workers*) (hash-table-count *buffer-hash*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *buffer-hash* (make-hash-table :weak-kind :key)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (list (length *workers*) (hash-table-count *buffer-hash*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *a* (list (cons 'superman 'metropolis) (cons 'batman 'gotham-city))) (assoc 'batman *a*) (cdr (assoc 'batman *a*)) (assoc 'donald-duck *a*) (push (cons 'donald-duck 'duckburg) *a*) (assoc 'donald-duck *a*) (push (cons 'donald-duck 'entenhausen) *a*) (assoc 'donald-duck *a*) (progn (pop *a*) (pop *a*) *a*) (setf *a* (acons 'donald-duck 'entenhausen *a*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (assoc "Batman" '(("Superman" . "Metropolis") ("Batman" . "Gotham City"))) (assoc "Batman" '(("Superman" . "Metropolis") ("Batman" . "Gotham City")) :test 'string=) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (assoc "batman" '(("Superman" . "Metropolis") ("Batman" . "Gotham City")) :test 'string=) (assoc "batman" '(("Superman" . "Metropolis") ("Batman" . "Gotham City")) :test 'string= :key 'string-downcase) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (assoc-if 'oddp '((2 . "two") (4 . "four") (3 . "three") (5 . "five"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf *a* (cons (cons 'lois-lane 'metropolis) *a*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (pairlis (list "Batman" "Superman" "Donald Duck") (list "Gotham City" "Metropolis" "Duckburg")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (rassoc "Metropolis" '(("Superman" . "Metropolis") ("Batman" . "Gotham City")) :test 'string=) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (cdr (assoc 'batman *a*)) 'new-york-city) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (cdr (assoc 'spider-man *a*)) 'new-york-city) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (sys:cdr-assoc 'spider-man *a*) 'new-york-city) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *l* (list 'superman 'metropolis 'batman 'gotham-city)) (getf *l* 'batman) (getf *l* 'donald-duck) (getf *l* 'donald-duck 'nirvana) (setf *l* (list* 'donald-duck 'duckburg *l*)) (getf *l* 'donald-duck) (setf *l* (list* 'donald-duck 'entenhausen *l*)) (getf *l* 'donald-duck) (remf *l* 'donald-duck) ,*l* (setf (getf *l* 'donald-duck) 'entenhausen) ,*l* (get-properties *l* '(batman superman)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *l* (loop for symbol in '(:a :b :c :d :e :f :g :h :i :j :k) ;; use ASCII code of symbol's character as value for code = (char-code (char (symbol-name symbol) 0)) collect symbol collect code)) ,*l* (let ((plist *l*) key value) (loop (multiple-value-setq (key value plist) (get-properties plist '(:f :j :a))) ;; leave loop if nothing was found (unless key (return)) ;; skip key/value pair which was found (setf plist (cddr plist)) ;; do something with the data (print (list key value)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; primes below 24 (defparameter *p* (list 2 3 5 7 11 13 17 19 23)) ;; odd numbers below 24 (defparameter *o* (list 1 3 5 7 9 11 13 15 17 19 21 23)) (union *p* *o*) (intersection *p* *o*) (set-difference *p* *o*) (set-difference *o* *p*) (set-exclusive-or *p* *o*) (subsetp *o* *p*) (subsetp '(11 23) *p*) (adjoin 2 *p*) (adjoin 29 *p*) (member 29 *p*) (member 17 *p*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (set-difference '("Groucho" "Chico" "Harpo") '("Groucho")) (set-difference '("Groucho" "Chico" "Harpo") '("Groucho") :test 'string=) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun set-equal (a b) (null (set-exclusive-or a b))) (set-equal '(1 2 2 3) '(3 3 1 1 2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun hash-set-union (a b) (let ((result (make-hash-table))) (loop for key being the hash-keys of a do (setf (gethash key result) t)) (loop for key being the hash-keys of b do (setf (gethash key result) t)) result)) (defun hash-set-intersection (a b) (let ((result (make-hash-table))) (loop for key being the hash-keys of a when (gethash key b) do (setf (gethash key result) t)) result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; *A* is the set {0,1,3} (defparameter *a* #b1011) ;; *B* is the set {0,3,4} (defparameter *b* #b11001) (setf *print-base* 2) ;; union (logior *a* *b*) ;; intersection (logand *a* *b*) ;; remove element 1 from set *A* (setf (ldb (byte 1 1) *a*) 0) ,*a* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-07 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-07/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (remove-if-not 'symbolp '(:foo 42 #\a bar "string" quux)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (remove #\a "Aardvark") (remove #\a "Aardvark" :test 'char-equal) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (find #\c "abcde") (find #\C "abcde") (find #\C "abcde" :test 'char-equal) (search "bcd" "abcde") (search "bdc" "abcde") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (find-if 'plusp '(-3 -13/17 -4.5 0 42)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (position #\c "abcde") (position #\x "abcde") (position-if 'plusp '(-3 -13/17 -4.5 0 42)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (find nil (list nil)) (position nil (list nil)) (find nil (list 42)) (position nil (list 42)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (position #\a "Zappa") (position #\a "Zappa" :from-end t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (find :d (list :a :b :c :d :e)) (member :d (list :a :b :c :d :e)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (search '(:c :d) '(a b c d e)) (search '(:c :d) '(a b c d e) :test 'string=) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mismatch "amnesty" "amnesia") (mismatch "and" "andante") (mismatch "and" "And" :test 'char-equal) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sort (list 3 1 2 5 4) '<) (merge 'list (list 2 4 8 16 32) (list 3 5 7 11 13 17 19) '<) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sort (list '(:three 3) '(:two 2) '(:four 4) '(:one 1)) (lambda (pair-1 pair-2) ;; we only use the second element of each pair (< (second pair-1) (second pair-2)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sort (list '(:three 3) '(:two 2) '(:four 4) '(:one 1)) '< :key 'second) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *list* (list 1 2 3 4 5)) (sort *list* '>) ,*list* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf *list* (sort *list* '>)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf *list* (sort (copy-list *list*) '>)) ;; or COPY-SEQ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sort (vector '(:two-1 2) '(:two-2 2) '(:one-1 1) '(:one-2 1)) '< :key 'second) (stable-sort (vector '(:two-1 2) '(:two-2 2) '(:one-1 1) '(:one-2 1)) '< :key 'second) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; list meets string (search '(#\b #\a #\r) "foobarbaz") ;; vector meets list (mismatch #(f r u g a l) '(f r u n o b u l a x)) ;; vector and list again (map 'list '+ #(1 2 3) '(3 2 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *text* "The thirty-three thieves thought that they thrilled the throne throughout Thursday.") (count #\t *text* :test 'char-equal) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (count #\t (subseq *text* 11 51) :test 'char-equal) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (count #\t *text* :test 'char-equal :start 11 :end 51) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun shared-subseq (sequence start end) (make-array (- end start) :element-type (array-element-type sequence) :displaced-to sequence :displaced-index-offset start)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for x in '#1=(a b c . #1#) repeat 30 collect x) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *c* '#1=(a b c . #1#)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf *print-circle* t) ,*c* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq *print-circle* nil) (let ((yo-1 (make-symbol "YO")) (yo-2 (make-symbol "YO"))) (list yo-1 yo-2 yo-1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq *print-circle* t) (let ((yo-1 (make-symbol "YO")) (yo-2 (make-symbol "YO"))) (list yo-1 yo-2 yo-1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq *print-circle* t) (defparameter *c* (list 'a 'b 'c)) (setf (cdr (last *c*)) *c*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with values = '(a b c) for i below 30 collect (nth (mod i 3) values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for flag = t then (not flag) repeat 10 collect flag) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for i from 5 to 1 collect i) (loop for i from 5 to 1 by -1 collect i) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for i downfrom 5 to 1 collect i) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun test (start end step) (loop for i = start then (+ i step) until (= i end) collect i)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test 1 5 1) (test 5 1 -1) (test 1 5 .3) ;; <- ATTENTION, WILL LOOP FOREVER ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun get-all-properties (plist keys) (loop for (key value) on plist by #'cddr when (member key keys) collect value)) (get-all-properties '(:one 1 :two 2 :three 3 :four 4 :five 5 :six 6 :seven 7) '(:one :five :two)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for thing on '(1 2 3 4) do (print thing)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for thing on '(1 2 3 4) by #'cddr do (print thing)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for thing on '(1 2 3 4) by #'cddr for (first second . rest) = thing do (print (list first second rest))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for (first second . nil) on '(1 2 3 4) by #'cddr do (print (list first second))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for (first second) on '(1 2 3 4) by #'cddr do (print (list first second))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for data = (list 1 2 3 4 5 6) then (nthcdr size data) for size in '(2 0 3 1) collect (subseq data 0 size)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mapcar 'funcall (loop for i below 10 collect (lambda () i))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let (closures) (dotimes (i 10) (push (lambda () i) closures)) (mapcar 'funcall (reverse closures))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mapcar 'funcall (loop for i below 10 collect (let ((j i)) ;; new binding (lambda () j)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for a in '(A B C D E F) for b in '(:A :B :C :D) collect (list a b)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for a in '(A B C D E F) for b% = '(:A :B :C :D) then (cdr b%) for b = (car b%) collect (list a b)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for a in '(A B C D E F) for b% = '(:A :B :C :D) then (cdr b%) for b = (if b% (car b%) 42) collect (list a b)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with b% = #(:A :B :C :D) with len = (length b%) for a across #(A B C D E F) for i from 0 for b = (and (< i len) (aref b% i)) collect (list a b)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for char across "counterrevolutionaries" when (find char "aeiou") collect char) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with counter = 0 for char across "counterrevolutionaries" until (= counter 5) when (find char "aeiou") collect char and do (incf counter)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with counter = 0 for char across "counterrevolutionaries" when (find char "aeiou") collect char into result ;; note INTO here and do (incf counter) when (= counter 5) return result) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with counter = 0 for char across "counterrevolutionaries" when (find char "aeiou") collect char into result and do (incf counter) (when (= counter 5) (return result))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with counter = 0 for char across "counterrevolutionaries" when (find char "aeiou") collect char into result and do (incf counter) (when (= counter 5) (return (coerce result 'string)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with counter = 0 for char across "dandelion" when (find char "aeiou") collect char into result and do (incf counter) (when (= counter 5) (return (coerce result 'string))) finally (return (coerce result 'string))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with counter = 0 for char across "dandelion" when (find char "aeiou") collect char into result and do (incf counter) (when (= counter 5) (loop-finish)) ;; <-- changed finally (return (coerce result 'string))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for i in '(3 7 8 1) do (print i) when (evenp i) return nil finally (print :done)) (loop for i in '(3 7 8 1) do (print i) when (evenp i) do (loop-finish) finally (print :done)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mapcar 'length '((1) (2) (3) (4))) (maplist 'length '((1) (2) (3) (4))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mapcar 'list '(1 2 3 4) '(:one :two :three :four)) (mapcan 'list '(1 2 3 4) '(:one :two :three :four)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *counter* 0) (mapc (lambda (x) (incf *counter* x)) '(1 2 3 4 5 6 7 8 9 10)) ,*counter* (setf *counter* 0) (mapl (lambda (x) (incf *counter* (length x))) ;; note the difference '(1 2 3 4 5 6 7 8 9 10)) ,*counter* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (map 'list '1+ '(0 1 2 3 4)) (map 'vector '1+ '(0 1 2 3 4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (map-into (make-list 4 :initial-element '-) '1+ '(0 1 2 3 4)) (map-into (make-array 6 :initial-element '-) '1+ '(0 1 2 3 4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (map-into (make-list 3) 'get-internal-run-time) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass file-sequence (sequence standard-object) ((path :initarg :path))) (defmethod sb-sequence:length ((sequence file-sequence)) (with-open-file (in (slot-value sequence 'path)) (file-length in))) (defmethod sb-sequence:elt ((sequence file-sequence) index) ;; silly example, see below (with-open-file (in (slot-value sequence 'path)) (file-position in index) (read-char in))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; results from a Linux system (defparameter *passwd* (make-instance 'file-sequence :path "/etc/passwd")) (length *passwd*) (search "bash" *passwd*) (subseq (coerce *passwd* 'list) 27 31) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (use-package :iter) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (iter (for i from 1 to 5) (collect (* i i))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (iter (for thing in '(:one :two :three)) (case thing (:one (collect 1)) (:two (appending (list 2 2))) (:three (collect 3) (appending (list 3 3))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for i in '(2 5 11 23) while (< i 17) for j = (print i) collect (list j j)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (iter (for i in '(2 5 11 23)) (while (< i 17)) (for j = (print i)) (collect (list j j))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (iter (for x from -5 to 5 by 1/100) (finding x minimizing (1+ (* x (- x 4))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (iter (for x in '(:foo foo 42 :bar #\a :quux "string")) (generate y in '(a b c)) (when (keywordp x) (collect (cons x (next y))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; on a Linux system: (iter (for c in-file "/etc/passwd" using 'read-char) (repeat 4) (collect c into result) (finally (return (coerce result 'string)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro-clause (collect-char char) `(accumulating ,char by (lambda (next-char array) (vector-push-extend next-char array) array) initial-value (make-array 0 :adjustable t :fill-pointer t :element-type 'character))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (iter (for c in-file "/etc/passwd" using 'read-char) (repeat 4) (collect-char c)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (use-package :series) (defun primep (n) (zerop (collect-length (choose-if (lambda (d) (zerop (mod n d))) (scan-range :from 2 :upto (sqrt n)))))) (defun all-primes () (choose-if 'primep (scan-range :from 2))) (subseries (all-primes) 0 10) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (collect 'string (subseries (choose-if (lambda (char) (find char "aeiou")) (scan "counterrevolutionaries")) 0 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-08 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-08/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-input-from-string (in "(#\\a \"foo\" #c(3 4) 4/5)") (read in)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (read-from-string "(nIL .3141d1 #.(print 42) foo)") (intern "FOO") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((input "84/2 #c(23 0)")) (multiple-value-bind (part-1 position) (read-from-string input) (list part-1 (read-from-string input t nil :start position)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (read-from-string "(+ 40 2)") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval (read-from-string "(+ 40 2)")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun count-1-2-3 (list) (let ((counters '(:one 0 :two 0 :three 0))) (dolist (item list) (incf (getf counters item))) counters)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (count-1-2-3 (list :one :three :three :one :one :one)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (count-1-2-3 (list :two :two)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun oldest-marx-brother () "Chico") (setf (subseq (oldest-marx-brother) 0 4) "Harp") ;; what follows is technically undefined behavior! (oldest-marx-brother) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun area (radius) (* 3.141592653589793D0 radius radius)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun area (radius) (* (* 4 (atan 1d0)) radius radius)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun area (radius) (* #.(* 4 (atan 1d0)) radius radius)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #.(let ((h (make-hash-table))) (setf (gethash 42 h) t) h) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compute-pi () (* 4 (atan 1d0))) (defun area (radius) (* #.(compute-pi) radius radius)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun banner () (format t "Version 4.2. Compiled at Lisp universal time ~A.~%" #.(get-universal-time))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *a* #(1 2 4 8 16)) (aref *a* 3) ,*a* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *a* #2A((1 2 4 8) (1 3 9 27))) (aref *a* 1 3) ,*a* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #4(1 2 3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #2A((1 2 4 8) (1 3 9 27)) (aref * 1 1) #1A((1 2 4 8) (1 3 9 27)) (aref * 1) #0A((1 2 4 8) (1 3 9 27)) (aref *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo (x) (+ x 42)) (flet ((foo (x) (1+ x))) (list (funcall 'foo 0) (funcall #'foo 0))) (funcall #'foo 0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (+ #1=21 #1#) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo () (let ((a (list #2='foo)) (b (list #2# #2#))) (append a b))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun bar () (list #2# 'bar)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a '#1=(10 . #1#))) (nth 42 a)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((a '(1 2 3)) (b '(1 2 3))) (list (equal a b) (eq a b))) (let ((a #1='(1 2 3)) (b #1#)) (list (equal a b) (eq a b))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf *readtable* (copy-readtable)) ;; now change the current readtable ;; and afterward enter forms to try out your new syntax (setf *readtable* (copy-readtable nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-input-from-string (in "10 10") (let ((*read-base* 16)) (list (read in) (with-standard-io-syntax (read in))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 'ab$c (set-syntax-from-char #\$ #\;) 'ab$c (setf *readtable* (copy-readtable nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (set-syntax-from-char #\$ #\\) 'a\$b$\c (setf *readtable* (copy-readtable nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (set-syntax-from-char #\$ #\|) 'a$"()$c 'a|"()$c (setf *readtable* (copy-readtable nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun brace-reader (stream char) (declare (ignore char)) (let ((hash (make-hash-table))) (loop for (key value) on (read-delimited-list #\} stream t) by #'cddr do (setf (gethash key hash) value)) hash)) (set-macro-character #\{ 'brace-reader) (set-macro-character #\} (get-macro-character #\) nil)) {:two 2 :five 5} (gethash :five *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (set-syntax-from-char #\! #\") !Hello World! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; {:two 2 :inner-hash {:one 1 :foo 'foo}} ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; {:two 2 :five 5 } ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; {:two 2 :five 5} ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *string-reader* (get-macro-character #\" nil)) (set-dispatch-macro-character #\# #\? (lambda (stream sub-char infix) (let ((string (funcall *string-reader* stream sub-char))) (cond (infix (remove (code-char infix) string)) (t string))))) #?abc? (char-code #\a) #97?abcacba? ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-dispatch-macro-character #\!) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-input-from-string (in "42 23") (read in) ;; <-- (list (read-char in) (read-char in))) (with-input-from-string (in "42 23") (read-preserving-whitespace in) ;; <-- (list (read-char in) (read-char in))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (read-from-string "424242 ") (read-from-string "424242 " t nil :preserve-whitespace t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-09 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-09/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (write 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-output-to-string (out) (write 42 :stream out)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*print-base* (write 42) (write 42 :base 16) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*print-gensym* (write (gensym "FOO") :gensym nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*print-array* (write #(1 2 3) :array nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*print-length* (dolist (len '(nil 0 1 2 3 4 5)) (write '(1 2 3 4 5) :length len) (terpri)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (write '(:foo (1 2 3 4 5)) :length 2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*print-level* (dolist (lev '(nil 0 1 2 3 4 5)) (write '(1 (2) (2 (3)) (2 (3 (4))) (2 (3 (4 (5))))) :level lev) (terpri)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (write 42 :level 0) (write '(42) :level 0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (write #(1 2 3) :length 2) (defstruct foo a b) (write (make-foo) :length 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*print-escape* (write #\X :escape nil) (write :x :escape nil) (write "X" :escape nil) (write #p"X" :escape nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq *print-length* 2) '(1 2 3) (setq *print-readably* t) '(1 2 3) ,*print-length* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (list (write-to-string 42) (format nil "~A" 42) (with-output-to-string (out) (format out "~A" 42))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *s* (make-array 25 :element-type 'character :fill-pointer t :initial-contents "Here please: __. Thanks!")) ,*s* (setf (fill-pointer *s*) 13) ,*s* (with-output-to-string (out *s*) (princ 42 out)) ,*s* (setf (fill-pointer *s*) 25) ,*s* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (setf (fill-pointer *s*) 13) (format *s* "~D" 23) (setf (fill-pointer *s*) 25) ,*s* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *s* (copy-seq "Here please: __. Thanks!")) (let ((s (make-array (length *s*) :element-type 'character :fill-pointer 13 :displaced-to *s*))) (format s "~D" 42)) ,*s* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "~A" nil) (format nil "~:A" nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "~:A" '(())) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "~A ~A" 42 23) (format nil "~A~ ~A" 42 23) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "~A~ ~A" 42 23) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "~A~: ~A" 42 23) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-report (fmt-ctrl &rest fmt-args) (with-output-to-string (out) (format out "Report: ") (apply #'format out fmt-ctrl fmt-args))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (my-report "All was ~A today." :fine) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((fmt-ctrl (formatter "All was ~A today."))) (my-report fmt-ctrl :ok)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((fmt-ctrl (lambda (stream adjective) (write-string "All was " stream) (princ adjective stream) (write-string " today." stream)))) (my-report fmt-ctrl 'cool)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun twice (stream arg &rest other-args) (declare (ignore other-args)) (format stream "~A~:*~A" arg)) (twice *standard-output* 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "~A~/twice/~A" #\b #\o #\t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :iso-8601 (:export :date)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun iso-8601:date (stream universal-time colon-p at-sign-p &rest params) (multiple-value-bind (sec min hour date mon year day dst zone) (decode-universal-time universal-time (first params)) (declare (ignore day dst)) (format stream "~4,'0D-~2,'0D-~2,'0D" year mon date) (unless colon-p (format stream "T~2,'0D:~2,'0D:~2,'0D" hour min sec) (when at-sign-p (multiple-value-bind (quo rem) (truncate zone) (format stream "~:[+~;-~]~2,'0D:~2,'0D" (minusp quo) (abs quo) (floor (abs (* rem 60))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with time = (get-universal-time) for fmt-ctl in '("~/iso-8601:date/" "~@/iso-8601:date/" "~:/iso-8601:date/" "~5@/iso-8601:date/" "~-3/iso-8601:date/") collect (format nil fmt-ctl time)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "X~?Y" "~%" nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "X~?~A" "~A~A" '(Y Z) :W) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "X~@?~A" "~A~A" :Y :Z :W) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (format nil "X~@?~A" "~A~@?" :Y "~A~A" :Z :W :V) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((fmt (formatter "~A~@?"))) (format nil "X~@?~A" fmt :Y "~A~A" :Z :W :V)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass foo () ((bar :initarg :bar))) (make-instance 'foo) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (read-from-string (prin1-to-string (make-instance 'foo))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod print-object ((object foo) stream) (print-unreadable-object (object stream :type t :identity t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-instance 'foo) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod print-object ((object foo) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "(BAR: ~S)" (slot-value object 'bar)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-instance 'foo :bar 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *last-id* 0) (defclass tag () ((name :initarg :name :reader name) (contents :initarg :contents :initform "" :reader contents) (id :initform (incf *last-id*) :reader id))) (defmethod print-object ((tag tag) stream) (format stream "<~A id='~A'>~A" (name tag) (id tag) (contents tag))) (make-instance 'tag :name 'foo) (make-instance 'tag :name 'bar :contents *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq *print-readably* t) (make-instance 'tag :name 'baz) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun calkin-wilf (value levels) (if (zerop levels) value (let* ((numerator (numerator value)) (denominator (denominator value)) (sum (+ numerator denominator))) (list value (calkin-wilf (/ numerator sum) (1- levels)) (calkin-wilf (/ sum denominator) (1- levels)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq *print-pretty* nil) (calkin-wilf 1 4) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((*print-right-margin* 30) (*print-miser-width* nil)) (pprint (calkin-wilf 1 4))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((*print-right-margin* 30) (*print-miser-width* nil)) (pprint '(defun fac (n) (if (zerop n) 0 (* n (fac (1- n))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun fake-code (level) (if (zerop level) '(do-something) `(when (test ,level) ,(fake-code (1- level))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((*print-right-margin* 30) (*print-miser-width* nil)) (pprint (fake-code 8))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((*print-right-margin* 30) (*print-miser-width* 20)) ;; <-- what we changed (pprint (fake-code 8))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((*print-right-margin* 30) (*print-miser-width* nil) (*print-lines* 5)) (pprint (fake-code 8))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((*print-pretty* t) (*print-right-margin* 40) (*print-miser-width* nil) (list (make-list 10 :initial-element :foo))) (format t "fill: ~/pprint-fill/ ~:*lin: ~/pprint-linear/ ~:*tab: ~7/pprint-tabular/" list) ;; increase margin (setq *print-right-margin* 60) (format t "~&~%lin: ~/pprint-linear/" list)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-pprint-fill (*standard-output* list) (pprint-logical-block (*standard-output* list) (pprint-exit-if-list-exhausted) (loop (write (pprint-pop)) (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-newline :fill)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((*print-pretty* t) (*print-right-margin* 5)) (pprint-logical-block (*standard-output* '(:foo :foo) :prefix "<" :suffix ">") (pprint-exit-if-list-exhausted) (loop (write (pprint-pop)) (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-newline :fill)))) (let ((*print-pretty* t) (*print-right-margin* 5)) (pprint-logical-block (*standard-output* '(:foo :foo) :per-line-prefix ";;; ") (pprint-exit-if-list-exhausted) (loop (write (pprint-pop)) (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-newline :fill)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass tag () ((name :initarg :name :reader name) (attributes :initarg :attributes :initform nil :reader attributes) (body :initarg :body :initform nil :reader body))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun pprint-tag (*standard-output* tag) (pprint-logical-block (*standard-output* nil) (write-char #\<) (write-string (name tag)) (pprint-logical-block (*standard-output* (attributes tag)) (pprint-exit-if-list-exhausted) (loop (write-char #\Space) (destructuring-bind (name value) (pprint-pop) (write-string name) (write-char #\=) (write-string value) (pprint-exit-if-list-exhausted) (pprint-newline :fill)))) (write-char #\>) (when (body tag) (pprint-indent :block 2) (pprint-newline :linear) (pprint-logical-block (*standard-output* (body tag)) (pprint-exit-if-list-exhausted) (loop (pprint-tag *standard-output* (pprint-pop)) (pprint-exit-if-list-exhausted) (pprint-newline :fill)))) (pprint-indent :block 0) (pprint-newline :linear) (write-string "))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((inner-1 (make-instance 'tag :name "INNER1" :attributes '(("id" "1")))) (inner-2 (make-instance 'tag :name "INNER2"))) (make-instance 'tag :name "OUTER" :attributes '(("id" "42") ("alt" "23")) :body (list inner-1 inner-2))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun pprint-tag (*standard-output* tag &rest other-args) (declare (ignore other-args)) (format t "~@<<~A~<~^~@{ ~A=~A~^~:_~}~:>>~ ~@[~2I~_~<~^~@{~/PPRINT-TAG/~^~:_~}~:>~]~0I~_~:>" (name tag) (mapcan 'copy-list (attributes tag)) (body tag))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (set-pprint-dispatch 'tag 'pprint-tag) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq *print-pretty* nil) (write (make-instance 'tag :name "FOO") :pretty t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (set-pprint-dispatch '(real 0 1) (lambda (stream number) (format stream "~,2F%" (* 100 number)))) (pprint (list 1/3 .3333 3333D-4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-10 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-10/foo.lisp][foo]] #+BEGIN_SRC lisp (defun test () (print (load-time-value (get-internal-real-time)))) #+END_SRC ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-10/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eql '(a (b c) (3/4 (d) e)) '(a (b c) (3/4 (d) e))) (tree-equal '(a (b c) (3/4 (d) e)) '(a (b c) (3/4 (d) e)) :test 'eq) (tree-equal '(a (b c) (3/4 (d) e)) (list 'a '(b c) (list 3/4 '(d) 'e)) :test 'eql) (tree-equal '(a (b c) (3/4 (d) e)) '(a (b c) (3/4 (d))) :test 'eql) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (equal '(1 #\a a) (list 1 #\a 'a)) (equal '(1 #\a a) (list 1 #\A 'a)) (eql "abc" "abc") (equal "abc" "abc") (equal "abc" (make-array 3 :element-type 'character :initial-contents (list #\a #\b #\c))) (equal (make-array 3 :element-type 'fixnum :initial-contents (list 1 2 3)) (make-array 3 :element-type 'fixnum :initial-contents (list 1 2 3))) (equal "abc" "Abc") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (equal #p"Test" #p"test") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (equalp "abc" "Abc") (equalp (make-array 3 :element-type 'fixnum :initial-contents (list 1 2 3)) (make-array 3 :element-type 'fixnum :initial-contents (list 1 2 3))) (flet ((test-hash () (let ((hash (make-hash-table))) (setf (gethash 42 hash) 'foo) hash))) (list (equal (test-hash) (test-hash)) (equalp (test-hash) (test-hash)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (case input (0 (stop-processing)) (1 (accelerate)) (2 (turn-left)) (3 (turn-right))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconstant +stop-command+ 0) (defconstant +speed-up-command+ 1) (defconstant +left-command+ 2) (defconstant +right-command+ 3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (case input (+stop-command+ (stop-processing)) (+speed-up-command+ (accelerate)) (+left-command+ (turn-left)) (+right-command+ (turn-right))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (case input (#.+stop-command+ (stop-processing)) (#.+speed-up-command+ (accelerate)) (#.+left-command+ (turn-left)) (#.+right-command+ (turn-right))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (case whatever (42 (do-something)) (#\Z (do-something-else)) (foo (do-something))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo (&key (arg 23)) (list arg)) (foo :arg 42) (foo) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun bar (&key ((:arg argument) 23)) (list argument)) (bar :arg 42) (bar) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun quux (&key ((:stream *standard-output*) ,*standard-output*)) (princ 42)) (quux) (with-output-to-string (out) (quux :stream out)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun baz (&key ((foo bar) 42)) (list bar)) (baz 'foo 23) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun color (&key (red 0.0) (green 0.0) (blue 0.0)) (list red green blue)) (color :red 0.3 :blue 0.4) (defun pure-color (which value) (color which value)) (pure-color :red 0.7) (pure-color :green 0.1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((counter 0)) (defun my-count () (print (incf counter)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((counter 0)) (defun reset-counter () (setf counter 0)) (defun my-count () (print (incf counter)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (my-count) (my-count) (my-count) (reset-counter) (my-count) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (get-internal-real-time) ;; the file "foo.lisp" can be found in this directory (compile-file "foo.lisp") (get-internal-real-time) (load **) (get-internal-real-time) (test) (get-internal-real-time) (test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (get-internal-real-time) (defun test-2 () (print (load-time-value (get-internal-real-time)))) (get-internal-real-time) (test-2) (test-2) (get-internal-real-time) (compile 'test-2) (get-internal-real-time) (test-2) (test-2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((counter 0)) (defun test () (print (load-time-value (format nil "~B" counter))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defadvice (sqrt no-complex-roots :around) (real) (if (minusp real) nil (call-next-advice real))) ;; <- call original SQRT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sqrt 3d0) (sqrt -3d0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (remove-advice 'sqrt 'no-complex-roots) (sqrt -3d0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (loop repeat 2000 sum most-positive-fixnum)) (defadvice (time keep-it-short :around) (form env) `(let* (result (output (with-output-to-string (*trace-output*) (setf result ,(call-next-advice form env))))) (format *trace-output* "~A" (subseq output (search "User time" output))) result)) (time (loop repeat 2000 sum most-positive-fixnum)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro swap (var-1 var-2) (let ((temp (gensym))) `(let ((,temp ,var-1)) (setf ,var-1 ,var-2 ,var-2 ,temp) (values)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *a* 42) (defparameter *b* 23) (swap *a* *b*) (list *a* *b*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((list (list 23 42))) (swap (first list) (second list)) list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((list (list 23 42))) (swap (nth (print 0) list) (second list)) list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((list (list 23 42))) (rotatef (nth (print 0) list) (second list)) list) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((arr (make-array 4 :initial-contents (list 1 2 3 4))) (list (list 10 20 30)) (var 42)) (print (list arr list var)) (rotatef (aref arr 0) (elt list 2) var (second list)) (list arr list var)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((arr (make-array 4 :initial-contents (list 1 2 3 4))) (list (list 10 20 30)) (var 42)) (print (list arr list var)) (print (shiftf (aref arr 0) (elt list 2) var (second list))) (list arr list var)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *latin-numbers* (make-hash-table :test 'equal)) (setf (gethash "II" *latin-numbers*) "duo" (gethash "III" *latin-numbers*) "tres" (gethash "VI" *latin-numbers*) "sex") (defun number-word (number) (gethash (format nil "~@R" number) *latin-numbers*)) (number-word 3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun (setf number-word) (new-value number) (setf (gethash (format nil "~@R" number) *latin-numbers*) new-value)) (setf (number-word 9) "novem") (number-word 9) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun set-number-word (number new-value) (setf (gethash (format nil "~@R" number) *latin-numbers*) new-value)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defsetf number-word set-number-word) (setf (number-word 7) "septem") (number-word 7) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *english-numbers* (make-hash-table :test 'equal)) (setf (gethash "one" *english-numbers*) 1 (gethash "two" *english-numbers*) 2 (gethash "fifteen" *english-numbers*) 15) (defun word-number (word) (values (gethash word *english-numbers*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-setf-expander word-number (word) (let ((new-value-var (gensym))) (values nil nil `(,new-value-var) `(setf (gethash ,word *english-numbers*) ,new-value-var) `(word-number ,word)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (word-number "one") (word-number "eight") (setf (word-number "eight") 8) (word-number "eight") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (word-number "fifteen") (setf (ldb (byte 1 0) (word-number "fifteen")) 0) (word-number "fifteen") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (ldb (byte 1 0) (word-number (print "fifteen"))) 0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-setf-expander word-number (word) (let ((word-var (gensym)) ;; <- new (new-value-var (gensym))) (values `(,word-var) ;; <- new `(,word) ;; <- new `(,new-value-var) `(setf (gethash ,word-var *english-numbers*) ;; <- changed ,new-value-var) `(word-number ,word-var)))) ;; <- changed ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (word-number "fifteen") (setf (ldb (byte 1 0) (word-number (print "fifteen"))) 1) (word-number "fifteen") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *alist* (list (cons 'donald-duck 'duckburg) (cons 'superman 'metropolis) (cons 'batman 'gotham-city))) (defun cdr-assoc (item alist) (cdr (assoc item alist))) (cdr-assoc 'batman *alist*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-setf-expander cdr-assoc (item alist) (let ((item-var (gensym)) (cons-found (gensym)) (alist-var (gensym)) (new-value-var (gensym))) (values `(,item-var ,alist-var ,cons-found) `(,item ,alist (assoc ,item-var ,alist-var)) `(,new-value-var) `(cond (,cons-found (setf (cdr ,cons-found) ,new-value-var)) (t (setf ,alist (acons ,item-var ,new-value-var ,alist-var)) ,new-value-var)) `(cdr ,cons-found)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cdr-assoc 'donald-duck *alist*) (setf (cdr-assoc 'donald-duck *alist*) 'entenhausen) (cdr-assoc 'donald-duck *alist*) (setf (cdr-assoc 'spider-man *alist*) 'new-york-city) (cdr-assoc 'spider-man *alist*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *container* (list :whatever *alist*)) (cdr-assoc 'daredevil (nth 1 *container*)) (setf (cdr-assoc 'daredevil (nth (print 1) *container*)) 'new-york-city) (cdr-assoc 'daredevil (nth 1 *container*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-setf-expander cdr-assoc (item alist &environment env) (multiple-value-bind (temp-vars temp-forms store-vars setter-form getter-form) (get-setf-expansion alist env) (let ((item-var (gensym)) (cons-found (gensym)) (new-value-var (gensym))) (values `(,@temp-vars ,item-var ,cons-found) `(,@temp-forms ,item (assoc ,item-var ,getter-form)) `(,new-value-var) `(cond (,cons-found (setf (cdr ,cons-found) ,new-value-var)) (t (let ((,(first store-vars) (acons ,item-var ,new-value-var ,getter-form))) ,setter-form ,new-value-var))) `(cdr ,cons-found))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro ashf (integer-place count) `(setf ,integer-place (ash ,integer-place ,count))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *x* 8) (ashf *x* -1) ,*x* (defparameter *arr* (make-array 10 :initial-element 16)) (ashf (aref *arr* (print 1)) -1) (aref *arr* 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-modify-macro ashf (count) ash) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *superheroes* (list (list 'superman 'clark-kent 'metropolis) (list 'batman 'bruce-wayne 'gotham-city))) (defun superhero-info (hero database) (let ((entry (assoc hero database))) (values (second entry) (third entry)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (superhero-info 'superman *superheroes*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-setf-expander superhero-info (hero database &environment env) (multiple-value-bind (temp-vars temp-forms store-vars setter-form getter-form) (get-setf-expansion database env) (let ((hero-var (gensym)) (entry-found (gensym)) (new-value-vars (list (gensym) (gensym)))) (values `(,@temp-vars ,hero-var ,entry-found) `(,@temp-forms ,hero (assoc ,hero-var ,getter-form)) `,new-value-vars `(cond (,entry-found (setf (cdr ,entry-found) (list ,@new-value-vars))) (t (let ((,(first store-vars) (cons (list ,hero-var ,@new-value-vars) ,getter-form))) ,setter-form (values ,@new-value-vars)))) `(values-list (rest ,entry-found)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (superhero-info 'spider-man *superheroes*) (setf (superhero-info 'spider-man *superheroes*) (values 'peter-parker 'new-york-city)) (superhero-info 'spider-man *superheroes*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro do-something (input) (if (constantp input) `(do-something-at-load-time ,input) `(do-something-at-run-time ,input))) (defun do-something-at-load-time (input) (declare (ignore input)) 'did-something-at-load-time) (defun do-something-at-run-time (input) (declare (ignore input)) 'will-do-something-at-run-time) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (do-something 42) (defconstant +foo+ 42) (do-something +foo+) (let ((foo 42)) (do-something foo)) (symbol-macrolet ((foo +foo+)) (do-something foo)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro do-something (input &environment env) ;; <- added env parameter (if (constantp input env) ;; <- used it `(do-something-at-load-time ,input) `(do-something-at-run-time ,input))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (symbol-macrolet ((foo +foo+)) (do-something foo)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun quick-approximation (arg) (declare (ignore arg)) 0) (defun slow-and-exact (arg) (declare (ignore arg)) 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-compiler-macro slow-and-exact (&whole form &environment env input) (if (eql 3 (second (assoc 'speed (introspect-environment:declaration-information 'optimize env)))) `(quick-approximation ,input) form)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun test-1 (input-list) (loop for input in input-list sum (slow-and-exact input))) (defun test-2 (input-list) (declare (optimize speed)) (loop for input in input-list sum (slow-and-exact input))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test-1 (list 1 2 3)) (test-2 (list 1 2 3)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-compiler-macro computation (&whole form &environment env input) (if (eql 'fixnum (cdr (assoc 'type (nth-value 2 (introspect-environment:variable-information input env))))) `(locally (declare (notinline computation)) (the fixnum (computation ,input))) form)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun test-1 (arg) (+ 42 (computation arg))) (defun test-2 (arg) (declare (fixnum arg)) (+ 42 (computation arg))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; (defun foo () 42) #| (defun bar () 43) (defun baz () 44) |# ,#+(or) (defun quux () 45) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,#+(or) #+(or) (foo) (bar) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-11 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-11/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *counter* 0) (defvar *thread*) (progn (setq *thread* (bt:make-thread (lambda () (sleep 2) (incf *counter*)))) (print *thread*) (sleep 1) ,*counter*) ;; wait at least a second ,*counter* ,*thread* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *counter* 0) (let ((thread (bt:make-thread (lambda () (sleep 5) (incf *counter*))))) (print (bt:thread-alive-p thread)) (sleep 1) (bt:destroy-thread thread) (sleep 1) (print (bt:thread-alive-p thread)) (sleep 5) ,*counter*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *counter* 0) (let* (please-stop ;; the flag (thread (bt:make-thread (lambda () (loop repeat 5 do (sleep 1) when please-stop do (return) finally (incf *counter*)))))) (print (bt:thread-alive-p thread)) (sleep 1) (setf please-stop t) ;; raise the flag (sleep 1) (print (bt:thread-alive-p thread)) (sleep 5) ,*counter*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop repeat 4 do (bt:make-thread (lambda () (loop)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *counter* 0) (defun test () (loop repeat 100 do (bt:make-thread (lambda () (loop repeat 100000 do (incf *counter*)) (loop repeat 100000 do (decf *counter*)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *counter* 0) (defparameter *lock* (bt:make-lock)) (defun test () (loop repeat 100 do (bt:make-thread (lambda () (loop repeat 100000 do (bt:with-lock-held (*lock*) (incf *counter*))) (loop repeat 100000 do (bt:with-lock-held (*lock*) (decf *counter*))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun test () (loop repeat 100 do (bt:make-thread (lambda () (loop repeat 100000 do (sys:atomic-incf *counter*)) (loop repeat 100000 do (sys:atomic-decf *counter*)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-hash-table :synchronized t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-hash-table :single-thread t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *a* (make-array 1000 :element-type '(signed-byte 4) :initial-element 0)) (defun writer (i) (loop repeat 100000 do (loop repeat 4 do (incf (aref *a* i))) (loop repeat 4 do (decf (aref *a* i))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mapc 'bt:make-thread (list (lambda () (writer 0)) (lambda () (writer 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *list* (make-list 10)) (defun swap () (let ((last-2 (last *list* 2)) (new-tail (make-list 5))) (setf (cdr (nthcdr 4 *list*)) new-tail (cdr last-2) nil))) (defun writer () (loop repeat 1000000 do (swap))) (defparameter *results* nil) (defun reader () (loop repeat 1000000 do (pushnew (length *list*) *results*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mapc 'bt:make-thread '(writer reader)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *foo* 42) (defparameter *results* nil) (bt:make-thread (lambda () (push *foo* *results*))) ,*results* (let ((*foo* :yo)) (bt:make-thread (lambda () (push *foo* *results*)))) ,*results* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *foo* 42) (defparameter *results* nil) (map nil 'bt:make-thread (list (lambda () (let ((*foo* 1)) (sleep .1) (push (cons 1 *foo*) *results*))) (lambda () (let ((*foo* 2)) (sleep .1) (push (cons 2 *foo*) *results*))))) ,*results* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (bt:make-thread (lambda () (print 42))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (bt:make-thread (lambda () (print 42 #.*standard-output*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *foo* 42) (defparameter *results* nil) (let ((bt:*default-special-bindings* '((*foo* . :yo)))) (bt:make-thread (lambda () (push *foo* *results*)))) ,*results* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((state :not-yet-started) (thread (bt:make-thread (lambda () (sleep 3) (setf state :finished))))) (bt:join-thread thread) state) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *new-result* nil) (defun producer () (dotimes (i 5) (setf *new-result* (* i i)) (sleep 1)) (setf *new-result* :done)) (defun consumer () (setf *new-result* nil) (bt:make-thread 'producer) (loop (case *new-result* (:done (return)) ((nil)) (otherwise (print *new-result*) (setf *new-result* nil))) (sleep .001))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *new-result* nil) (defun producer (cv lock) (flet ((set-value-and-notify (new-value) (bt:with-lock-held (lock) (setf *new-result* new-value) (bt:condition-notify cv)))) (dotimes (i 5) (set-value-and-notify (* i i)) (sleep 1)) (set-value-and-notify :done))) (defun consumer () (let ((cv (bt:make-condition-variable)) (lock (bt:make-lock))) (bt:make-thread (lambda () (producer cv lock))) (loop (bt:with-lock-held (lock) (bt:condition-wait cv lock) (when (eql *new-result* :done) (return)) (print *new-result*))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun seed () (random 100000000)) (deftype von-neumann () '(integer 0 99999999)) (defun middle-square (seed n) (declare (optimize speed) (type von-neumann seed) (fixnum n)) (loop for i below n for val of-type von-neumann = seed then (mod (floor (* val val) 10000) 100000000) finally (return val))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *seeds* (coerce (loop repeat 40000 collect (seed)) 'vector)) (defparameter *repetitions* (coerce (loop repeat 40000 collect (random 100000)) 'vector)) (defun test () (map 'vector 'middle-square *seeds* *repetitions*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf lparallel:*kernel* (lparallel:make-kernel 4)) (defun ptest () (lparallel:pmap 'vector 'middle-square *seeds* *repetitions*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun mult (a b) ;; number of bits the larger factor has (let ((length (max (integer-length a) (integer-length b)))) (when (< length 100000) ;; numbers are "small" (return-from mult (* a b))) (let* ((length/2 (floor length 2)) ;; half of the bits (mask (1- (ash 1 length/2))) ;; bitmask for right half (a1 (ash a (- length/2))) ;; left half of A (a2 (logand a mask)) ;; right half of A (b1 (ash b (- length/2))) ;; left half of B (b2 (logand b mask)) ;; right half of B (a1*b1 (mult a1 b1)) (a2*b2 (mult a2 b2)) (prod3 (mult (+ a1 a2) (+ b1 b2)))) (+ (ash a1*b1 (* 2 length/2)) a2*b2 (ash (+ prod3 (- a1*b1) (- a2*b2)) length/2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun pmult% (a b tree) (let ((length (max (integer-length a) (integer-length b)))) (when (< length 100000) (let ((result (gensym))) ;; add function to ptree using name RESULT (lparallel:ptree-fn result () ;; this function has no dependencies (lambda () (* a b)) tree) ;; return this name (return-from pmult% result))) (let* ((length/2 (floor length 2)) (mask (1- (ash 1 length/2))) (a1 (ash a (- length/2))) (a2 (logand a mask)) (b1 (ash b (- length/2))) (b2 (logand b mask)) ;; the following three are now symbols instead of numbers (a1*b1 (pmult% a1 b1 tree)) (a2*b2 (pmult% a2 b2 tree)) (prod3 (pmult% (+ a1 a2) (+ b1 b2) tree)) (result (gensym))) ;; add function to ptree using name RESULT and ;; tell lparallel which results this'll depend on (lparallel:ptree-fn result (list a1*b1 a2*b2 prod3) (lambda (a1*b1 a2*b2 prod3) (+ (ash a1*b1 (* 2 length/2)) a2*b2 (ash (+ prod3 (- a1*b1) (- a2*b2)) length/2))) tree) ;; return the name as above result))) (defun pmult (a b) (let ((tree (lparallel:make-ptree))) (lparallel:call-ptree (pmult% a b tree) tree))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf lparallel:*kernel* (lparallel:make-kernel 4)) (defparameter *a* (random (expt 2 1000000))) (defparameter *b* (random (expt 2 1000000))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (defparameter *p1* (mult *a* *b*))) (time (defparameter *p2* (pmult *a* *b*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconstant +sc-nprocessors-onln+ 84) (cffi:defcfun "sysconf" :long (name :int)) (defun get-number-of-processors () (sysconf +sc-nprocessors-onln+)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:defctype dword :unsigned-long) (cffi:defctype word :unsigned-short) (cffi:defcstruct processor-struct (processor-architecture word) (reserved word)) (cffi:defcunion oem-union (oem-ide dword) (processor-struct (:struct processor-struct))) (cffi:defcstruct system-info (oem-info (:union oem-union)) (page-size dword) (minimum-application-address :pointer) (maximum-application-address :pointer) (active-processor-mask (:pointer dword)) (number-of-processors dword) (processor-type dword) (allocation-granularity dword) (processor-level word) (processor-revision word)) (cffi:defcfun ("GetSystemInfo" get-system-info) :void (data (:pointer (:struct system-info)))) (defun get-number-of-processors () (cffi:with-foreign-object (info '(:struct system-info)) (get-system-info info) (cffi:foreign-slot-value info '(:struct system-info) 'number-of-processors))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-12 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-12/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-sqrt (x) (check-type x (real 0)) (sqrt x)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-sqrt (list) (check-type (first list) (real 0) "a non-negative real number") (sqrt (first list))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *l* (list -9 :whatever)) (my-sqrt *l*) ,*l* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-sqrt (x) (declare (type (real 0) x)) (sqrt x)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun dot-product (x y) (assert (and (typep x '(or list vector)) (typep y '(or list vector)) (= (length x) (length y))) (x y) "~S and ~S should have been sequences of the same length." x y) (reduce '+ (map 'list '* x y))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (dot-product '(2 3 4) '(4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro assert* (test-form &rest other-args) (declare (ignorable test-form other-args)) #-:release `(assert ,test-form ,@other-args)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (pushnew :release *features*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-condition too-expensive (error) ((price :initarg :price :reader price)) (:report (lambda (condition stream) (format stream "At ~A Euro~:P that's too expensive." (price condition))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-condition 'too-expensive :price 42) (format nil "~A" *) (error **) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (signal (make-condition 'error)) (list (signal (make-condition 'error)) 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (handler-case (list (signal (make-condition 'error)) 42) (error () (list :foo :bar))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (list (error (make-condition 'error)) 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (handler-case (list (error (make-condition 'error)) 42) ;; changed (error () (list :foo :bar))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (list (cerror "Proceed." (make-condition 'error)) 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (list (warn (make-condition 'warning)) 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (signal 'unbound-variable :name 'foo) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (signal (make-condition 'unbound-variable :name 'foo)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (error "~S and ~S don't match." :foo "FOO") (error (make-condition 'simple-error ;; <- default type :format-control "~S and ~S don't match." :format-arguments (list :foo "FOO"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (warn "~S and ~S don't match." :foo "FOO") (warn (make-condition 'simple-warning ;; <- default type :format-control "~S and ~S don't match." :format-arguments (list :foo "FOO"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun test (a b) (handler-case (/ a b) (type-error (condition) (format *error-output* "Oops, ~S should have been of type ~A." (type-error-datum condition) (type-error-expected-type condition)) :no-meaningful-result) (division-by-zero () (format *error-output* "This might create black holes!") (values)))) (test 42 7) (test 42 "23") (test 42 0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test most-positive-double-float least-positive-double-float) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *special* :old) (defun div (x y) (let ((*special* :new)) (catch 'catch-tag (/ x y)))) (defun test (a b) (handler-case (div a b) (type-error (condition) (format *error-output* "Oops, ~S should have been of type ~A." (type-error-datum condition) (type-error-expected-type condition)) ,*special*) (division-by-zero () (format *error-output* "This might create black holes!") (throw 'catch-tag -1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test 100 "NaN") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test 42 0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *special* :old) (defun div (x y) (let ((*special* :new)) (catch 'catch-tag (/ x y)))) (defun handler-2 (condition) (declare (ignore condition)) (format *error-output* "This might create black holes!") (throw 'catch-tag -1)) (defun test (a b) (flet ((handler-1 (condition) (format *error-output* "Oops, ~S should have been of type ~A." (type-error-datum condition) (type-error-expected-type condition)) (return-from test *special*))) (handler-bind ((type-error #'handler-1) (division-by-zero #'handler-2)) (div a b)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test 100 "NaN") (test 42 0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ignore-errors (parse-integer "42")) (ignore-errors (parse-integer "fourty-two")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-condition not-a-percentage (error) ((dividend :initarg :dividend :reader dividend) (divisor :initarg :divisor :reader divisor)) (:report (lambda (condition stream) (format stream "The quotient ~A/~A is not between 0 and 1." (dividend condition) (divisor condition))))) (defun percentage (a b) (restart-case (let ((ratio (/ a b))) (unless (typep ratio '(real 0 1)) (error 'not-a-percentage :dividend a :divisor b)) (format nil "~,2F%" (* 100 ratio))) (use-other-values (new-a new-b) :report "Use two other values instead." :interactive (lambda () (flet ((get-value (name) (format t "~&Enter new value for ~A: " name) (read))) (list (get-value 'a) (get-value 'b)))) (format nil "~,2F%" (* 100 (/ new-a new-b)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (percentage 3 7) (percentage 4 2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun percentage (a b) (restart-case (let ((ratio (/ a b))) (unless (typep ratio '(real 0 1)) (error 'not-a-percentage :dividend a :divisor b)) (format nil "~,2F%" (* 100 ratio))) (use-other-values (new-a new-b) :report "Use two other values instead." :interactive (lambda () (flet ((get-value (name) (format t "~&Enter new value for ~A: " name) (read))) (list (get-value 'a) (get-value 'b)))) (percentage new-a new-b)))) ;; <-- changed ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (handler-bind ((not-a-percentage (lambda (condition) (declare (ignore condition)) (invoke-restart 'use-other-values 1 10)))) (percentage 4 2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun divide-by-three (arg) (loop (restart-case (let ((type-error (make-condition 'type-error :expected-type 'integer :datum arg))) (with-condition-restarts type-error (list (find-restart 'parse-string)) (cond ((stringp arg) (error type-error)) ((zerop (mod arg 3)) (return (/ arg 3))) (t (error "Not divisible by three."))))) (parse-string () (setf arg (parse-integer arg))) (increase-value () :test (lambda (condition) (declare (ignore condition)) (typep arg 'integer)) (incf arg)) (decrease-value () :test (lambda (condition) (declare (ignore condition)) (typep arg '(integer 2))) (decf arg))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (divide-by-three 2) (divide-by-three 1) (divide-by-three "3") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-condition too-many-iterations (error) ()) (defun collatz (start &optional (max 10)) (let ((count 0) (value start)) (loop (incf count) (setf value (if (evenp value) (/ value 2) (1+ (* 3 value)))) (when (= value 1) (return)) (when (>= count max) (cerror "Continue trying?" 'too-many-iterations) (setf max (* 2 max)))) (format t "Reached end after ~A iterations." count))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (handler-bind ((too-many-iterations #'continue)) (collatz 6171)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-expt (base power) (unless (and (typep power 'integer) (typep base '(or rational (complex rational)))) (warn "Result may have round-off errors.")) (expt base power)) (my-expt 10 (log 1/4 10)) (handler-bind ((warning #'muffle-warning)) (my-expt 10 (log 1/4 10))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass fridge () ((door-open-p :initform nil :accessor door-open-p) (eggs :initform 10 :accessor eggs))) (define-condition fridge-error (error) ((fridge :initarg :fridge :reader fridge))) (define-condition no-eggs (fridge-error) ()) (defmethod open-door ((fridge fridge)) (setf (door-open-p fridge) t)) (defmethod close-door ((fridge fridge)) (setf (door-open-p fridge) nil)) (defmethod remove-egg ((fridge fridge)) (unless (plusp (eggs fridge)) (error 'no-eggs :fridge fridge)) (decf (eggs fridge))) (defmethod get-some-eggs ((fridge fridge) n) (open-door fridge) (loop repeat n do (remove-egg fridge)) (close-door fridge) ;; return number of eggs left (eggs fridge)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *fridge* (make-instance 'fridge)) (door-open-p *fridge*) (get-some-eggs *fridge* 7) (door-open-p *fridge*) (handler-bind ((no-eggs #'abort)) (get-some-eggs *fridge* 4)) (door-open-p *fridge*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod get-some-eggs ((fridge fridge) n) (open-door fridge) (unwind-protect (loop repeat n do (remove-egg fridge)) (close-door fridge)) (eggs fridge)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (setf (eggs *fridge*) 4) (close-door *fridge*) (handler-bind ((no-eggs #'abort)) (get-some-eggs *fridge* 7)) (door-open-p *fridge*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-13 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-13/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftype zahl (&optional from to) `(integer ,from ,to)) (deftype small-prime () '(member 2 3 5 7 11 13 17 19)) (defun test (x) (typecase x ((not zahl) :not-an-integer) ((zahl * 1) :primes-are-greater-than-one) (small-prime :definitely-prime) (otherwise :could-be-prime))) (mapcar 'test '(two 23.0 -10 17 15485863)) (defun has-simple-name (symbol) (let ((name (symbol-name symbol))) (and (< (length name) 5) (every (lambda (char) (char-not-greaterp #\a char #\z)) name)))) (deftype simple-symbol () '(and symbol (satisfies has-simple-name))) (mapcar (lambda (thing) (typep thing 'simple-symbol)) (list "foo" 'foo 'foobar 'x42 '|qUUx|)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftype zahl () 'integer) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun zahl () 'integer) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftype zahl (from to) `(integer ,from ,to)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftype zahl (&optional from to) `(integer ,from ,to)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftype my-number (&key from to (exactp t)) `(,(if exactp 'rational 'real) ,from ,to)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass foo () ()) (defparameter *f* (make-instance 'foo)) (typep *f* 'foo) (defun test (x) (typecase x (number (1+ x)) (foo :foo) (otherwise nil))) (mapcar 'test (list 42 *f* "foo")) (deftype bar () '(or foo number)) (subtypep 'foo 'bar) (typep 23 'bar) (typep *f* 'bar) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod gamma ((x number)) ;; Taylor series approximation ;; see for example http://rosettacode.org/wiki/Gamma_function ) (defmethod gamma ((n integer)) (if (plusp n) ;; compute factorial of (1- N) if N is a positive integer (loop for i from 1 to (1- n) for result = 1 then (* result i) finally (return result)) ;; otherwise use method above (call-next-method))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric factorial (n) (:method ((n (eql 0))) 1) (:method ((n integer)) (* n (factorial (1- n))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; will signal an error: (defmethod gamma ((n (integer 1 *))) (loop for i from 1 to (1- n) for result = 1 then (* result i) finally (return result))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; this is fine: (deftype positive-integer () '(integer 1 *)) ;; but this will signal an error: (defmethod gamma ((n positive-integer)) (loop for i from 1 to (1- n) for result = 1 then (* result i) finally (return result))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass foo () ((key :reader key))) (defun make-key (secret) (format nil "~A-~A" secret (random 100))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod initialize-instance :after ((new-object foo) &key secret) (setf (slot-value new-object 'key) (make-key secret))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-instance 'foo :secret "confidential") (key *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass bar () ((range :initarg :range :reader range))) (defun make-bar (begin end) (make-instance 'bar :range (loop for i from begin to end collect i))) (make-bar 3 10) (range *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod make-instance :around ((class (eql 'bar)) &key begin end) (cond ((and begin end) (call-next-method class :range (loop for i from begin to end collect i))) (t (call-next-method)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (range (make-instance 'bar :range '(a b c))) (range (make-instance 'bar :begin 40 :end 44)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass foo () ((bar))) (defmethod (setf closer-mop:slot-value-using-class) :after (new-value (class standard-class) (object foo) slot) (when (eql (closer-mop:slot-definition-name slot) 'bar) (print (list :bar-changed-to new-value)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (slot-value (make-instance 'foo) 'bar) 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass geometry-object () ()) (defclass scalar (geometry-object) ()) (defclass vec (geometry-object) ()) (defclass matrix (geometry-object) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod mult ((factor1 geometry-object) (factor2 vec)) :use-fast-simd-routines) (defmethod mult ((factor1 vec) (factor2 matrix)) :use-fast-simd-routines) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod mult ((factor1 scalar) (factor2 geometry-object)) :iterate-through-all-entries) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod mult ((factor1 matrix) (factor2 matrix)) :double-iteration) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mult (make-instance 'scalar) (make-instance 'vec)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric mult (factor-1 factor-2) (:argument-precedence-order factor-2 factor-1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (mult (make-instance 'scalar) (make-instance 'vec)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass foo () ((first-access :reader first-access))) (defparameter *foo* (make-instance 'foo)) (defmethod slot-unbound (class (object foo) (slot-name (eql 'first-access))) (setf (slot-value object 'first-access) (get-universal-time))) (get-universal-time) (first-access *foo*) (get-universal-time) (first-access *foo*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass foo () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (defparameter *object* (make-instance 'foo :a 1 :b 2)) (describe *object*) (defclass bar () ((b :initarg :b) (c :initarg :c) (d :initarg :d))) (change-class *object* 'bar) (describe *object*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above with same class definitions (defparameter *object* (make-instance 'foo :a 1 :b 2)) (change-class *object* 'bar :c 3 :d 4) (describe *object*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass person1 () ((fname :initarg :fname) (lname :initarg :lname) (city :initarg :city))) (defclass person2 () ((name :initarg :name) (city :initarg :city))) (defparameter *batman* (make-instance 'person1 :fname "Bruce" :lname "Wayne" :city "Gotham City")) (describe *batman*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod update-instance-for-different-class ((old person1) (new person2) &key) (setf (slot-value new 'name) (format nil "~A ~A" (slot-value old 'fname) (slot-value old 'lname)))) (change-class *batman* 'person2) (describe *batman*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass foo () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (defparameter *object* (make-instance 'foo :a 1 :b 2)) (describe *object*) (defclass foo () ;; <-- same class ((b :initarg :b) (c :initarg :c) (d :initarg :d))) ;; <-- new slot (describe *object*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass person () ((fname :initarg :fname) (lname :initarg :lname) (city :initarg :city))) (defparameter *batman* (make-instance 'person :fname "Bruce" :lname "Wayne" :city "Gotham City")) (describe *batman*) (defclass person () ;; <-- same class ((name :initarg :name) (city :initarg :city))) (defmethod update-instance-for-redefined-class ((object person) added deleted plist &key) (declare (ignore added deleted)) (setf (slot-value object 'name) (format nil "~A ~A" (getf plist 'fname) (getf plist 'lname)))) (describe *batman*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass point () ((x :initarg :x :reader x) (y :initarg :y :reader y))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod distance ((p1 point) (p2 point)) (sqrt (+ (expt (- (x p1) (x p2)) 2) (expt (- (y p1) (y p2)) 2)))) (defmethod distance-from-origin ((p point)) (distance #.(make-instance 'point :x 0 :y 0) p)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod make-load-form ((p point) &optional environment) (declare (ignore environment)) `(make-instance 'point :x ,(x p) :y ,(y p))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod make-load-form ((p point) &optional environment) (declare (ignore environment)) (make-load-form-saving-slots p :slot-names '(x y))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (make-load-form (make-instance 'point :x 0 :y 0)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass quadrilateral () ()) (defclass kite (quadrilateral) ()) (defclass parallelogram (quadrilateral) ()) (defclass trapezoid (quadrilateral) ()) (defclass rhombus (kite parallelogram) ()) (defclass rectangle (parallelogram trapezoid) ()) (defclass square (rectangle rhombus) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric symmetries (shape) (:method-combination append)) (defmethod symmetries append ((shape quadrilateral)) '(:identity)) (defmethod symmetries append ((shape kite)) '(:reflection-horizontal)) (defmethod symmetries append ((shape parallelogram)) '(:rotation-180-degrees)) (defmethod symmetries append ((shape rhombus)) '(:reflection-vertical)) (defmethod symmetries append ((shape rectangle)) '(:reflection-vertical :reflection-horizontal)) (defmethod symmetries append ((shape square)) '(:rotation-90-degrees :rotation-270-degrees :reflection-diagonal-1 :reflection-diagonal-2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (symmetries (make-instance 'rectangle)) (symmetries (make-instance 'rhombus)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (append '(:reflection-vertical) ;; from RHOMBUS '(:reflection-horizontal) ;; from KITE '(:rotation-180-degrees) ;; from PARALLELOGRAM '(:identity)) ;; from QUADRILATERAL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric symmetries (shape) (:method-combination append :most-specific-last)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (symmetries (make-instance 'square)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod symmetries :around ((shape quadrilateral)) (remove-duplicates (call-next-method))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun set-union (&rest sets) (reduce 'union sets)) (define-method-combination set-union) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-method-combination set-union :operation set-union) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric symmetries (shape) (:method-combination set-union)) (defmethod symmetries set-union ((shape quadrilateral)) '(:identity)) (defmethod symmetries set-union ((shape kite)) '(:reflection-horizontal)) (defmethod symmetries set-union ((shape parallelogram)) '(:rotation-180-degrees)) (defmethod symmetries set-union ((shape rhombus)) '(:reflection-vertical)) (defmethod symmetries set-union ((shape rectangle)) '(:reflection-vertical :reflection-horizontal)) (defmethod symmetries set-union ((shape square)) '(:rotation-90-degrees :rotation-270-degrees :reflection-diagonal-1 :reflection-diagonal-2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun number-qualifier-p (method-qualifiers) (and (numberp (first method-qualifiers)) (null (rest method-qualifiers)))) (define-method-combination weighted-sum (&optional (initial-value 0)) ((instead-methods (:instead)) (sum-methods number-qualifier-p)) (cond (instead-methods `(call-method ,(first instead-methods) ,(rest instead-methods))) (t `(let ((sum ,initial-value)) ,@(loop for method in sum-methods collect `(incf sum (* ,(first (method-qualifiers method)) (call-method ,method)))) sum)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric foo (number) (:method-combination weighted-sum 42)) (defmethod foo 2 ((x real)) x) (defmethod foo 10 ((x rational)) x) (defmethod foo :instead ((x fixnum)) x) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (foo 10.0) (foo 1/2) (foo 23) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass logged-class (standard-class) ((creation-log :initform nil :accessor creation-log))) (defmethod closer-mop:validate-superclass ((class logged-class) (superclass standard-class)) t) (defmethod make-instance :around ((class logged-class) &key) (let ((new-object (call-next-method))) (push (format nil "~A created at ~A." new-object (get-universal-time)) (creation-log class)) new-object)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass foo () () (:metaclass logged-class)) (make-instance 'foo) (make-instance 'foo) (creation-log (class-of *)) (defclass bar () () (:metaclass logged-class)) (make-instance 'bar) (creation-log (class-of *)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass quux () ()) (make-instance 'quux) (class-of *) (class-of *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass foo () ((creation-log :initform nil :accessor creation-log :allocation :class))) ;; <-- this is new (defmethod make-instance :around ((class (eql 'foo)) &key) ;; <-- one specific class (let ((new-object (call-next-method))) (push (format nil "~A created at ~A." new-object (get-universal-time)) (creation-log new-object)) ;; <-- hangs off class new-object)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-14 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-14/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo (n) (make-list n :initial-element (read))) (with-input-from-string (stream "42") (let ((*standard-input* stream)) (foo 3))) (let ((apropos-result (with-output-to-string (stream) (let ((*standard-output* stream)) (apropos 'foo))))) apropos-result) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-input-from-string (*standard-input* "42") (foo 3)) (with-output-to-string (*standard-output*) (apropos 'foo)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((*print-base* 2)) (print 10)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((result (with-output-to-string (stream) (let ((my-standard-output (make-synonym-stream '*standard-output*))) (print 42 my-standard-output) (let ((*standard-output* stream)) (print 43 my-standard-output)) (print 44 my-standard-output))))) result) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (progn (write-char #\.) (sleep 2) (write-char #\.) (values)) (progn (write-char #\.) (force-output) (sleep 2) (write-char #\.) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (in "C:/Windows/winhlp32.exe" :element-type '(unsigned-byte 8)) (file-length in)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun file-at-once (filespec &rest open-args) (with-open-stream (stream (apply #'open filespec open-args)) (let* ((buffer (make-array (file-length stream) :element-type (stream-element-type stream) :fill-pointer t)) (position (read-sequence buffer stream))) (setf (fill-pointer buffer) position) buffer))) (defun number-of-users () (count #\Newline (file-at-once "/etc/passwd" :element-type 'character))) (number-of-users) (subseq (hcl:file-string "/etc/passwd") 0 4) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (stream-1 "/tmp/foo1" :direction :output) (with-open-file (stream-2 "/tmp/foo2" :direction :output) (let ((out (make-broadcast-stream stream-1 stream-2))) (format out "This line goes to foo1 and foo2~%") (format stream-1 "Only foo1~%") (format stream-2 "Only foo2~%") (format out "Again both files~%")))) (file-at-once "/tmp/foo1") (file-at-once "/tmp/foo2") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (log-file-stream "/tmp/log" :direction :output) (let ((log-stream (make-broadcast-stream log-file-stream ,*error-output*))) (format log-stream "An error occurred~%") (with-open-file (*error-output* "/tmp/log2" :direction :output) (format log-stream "Another error occurred~%")) (format log-stream "Zounds! Again an error!~%"))) (file-at-once "/tmp/log2") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (log-file-stream "/tmp/log" :direction :output :if-exists :supersede) (let ((log-stream (make-broadcast-stream log-file-stream (make-synonym-stream '*error-output*)))) (format log-stream "An error occurred~%") (with-open-file (*error-output* "/tmp/log2" :direction :output :if-exists :supersede) (format log-stream "Another error occurred~%")) (format log-stream "Zounds! Again an error!~%"))) (file-at-once "/tmp/log2") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun print-some-stuff () (dotimes (i 10) (format t "~R~%" i))) (print-some-stuff) (let ((*standard-output* (make-broadcast-stream))) (print-some-stuff)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-input-from-string (s "(41 42 43)") (second (read s))) (with-input-from-string (s "(41 42 43)" :start 4 :end 5) (read s)) (with-output-to-string (s) (write-string "Look: " s) (princ (list 1 2 3) s)) (let ((string (make-array 0 :element-type 'character :fill-pointer t :adjustable t))) (vector-push-extend #\[ string) (with-output-to-string (s string) (write-string "Look: " s) (princ (list 1 2 3) s)) (vector-push-extend #\] string) string) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop with ptr = 0 with eof = (gensym) for from = ptr for object = (with-input-from-string (s "41 42 43" :start ptr :index ptr) (read s nil eof)) until (eq object eof) do (format t "~A-~A: ~A~%" from ptr object) finally (return (values))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((s (make-string-input-stream "41 42 43")) (a (read s)) (b (read s))) (list a b (read s))) (let ((s (make-string-output-stream))) (write-string "Look: " s) (princ (list 1 2 3) s) (format t "1: ~S~%" (get-output-stream-string s)) (write-string "More..." s) (format t "2: ~S~%" (get-output-stream-string s))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (read-line (make-concatenated-stream (make-string-input-stream "Duc") (make-string-input-stream "k So") (make-string-input-stream "up"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/foo.txt" :direction :output) (write-line "First line" out) (write-line "Second line" out) (write-line "The third line" out :start 4 :end 9) (write-string "Last line, without Newline" out)) (with-open-file (in "/tmp/foo.txt") (loop for (line no-nl-p) = (multiple-value-list (read-line in nil nil)) while line do (format t "~S~:[ ~;~]~%" line no-nl-p))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/foo.txt" :direction :output :if-exists :supersede :external-format '(:e-crlf :latin1)) (write-line "First line" out) (write-line "Second line" out) (write-line "The third line" out :start 4 :end 9) (write-string "Last line, without Newline" out)) (with-open-file (in "/tmp/foo.txt") (loop for line = (read-line in nil) while line do (format t "~S~%" (char line (1- (length line)))))) (with-open-file (in "/tmp/foo.txt" :external-format '(:e-crlf :latin1)) (loop for line = (read-line in nil) while line do (format t "~S~%" (char line (1- (length line)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (handler-case (with-open-file (in "/tmp/foo.txt") (loop for line = (read-line in) do (format t "~S~%" line))) (end-of-file () (format t "-->END OF FILE HERE<--~%"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/data" :direction :output :element-type '(signed-byte 16)) (dolist (byte '(28483 27503 28514 27503)) (write-byte byte out))) (with-open-file (in "/tmp/data" :element-type '(signed-byte 16)) (loop for byte = (read-byte in nil) while byte collect byte)) (with-open-file (in "/tmp/data" :element-type '(signed-byte 32)) (loop for byte = (read-byte in nil) while byte collect byte)) (+ 28483 (* 65536 27503)) (with-open-file (in "/tmp/data" :element-type '(unsigned-byte 8)) (loop for byte = (read-byte in nil) while byte collect byte)) (+ 67 (* 256 111)) (with-open-file (in "/tmp/data") (read-line in)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/data" :direction :output :if-exists :supersede :element-type '(signed-byte 16)) (write-sequence '(100 200 300 400 500 600 700) out :start 2 :end 6)) (with-open-file (in "/tmp/data" :element-type '(signed-byte 16)) (let ((result (make-array 8 :initial-element 0))) (read-sequence result in :start 3 :end 7) result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/data" :direction :output :if-exists :supersede :element-type '(mod 16)) (dotimes (i 16) (write-byte i out))) (let ((*print-length* nil)) (with-open-file (in "/tmp/data" :element-type '(mod 16)) (print (loop for byte = (read-byte in nil) while byte collect byte))) (values)) (let ((*print-length* nil)) (with-open-file (in "/tmp/data" :element-type '(unsigned-byte 8)) (print (loop for byte = (read-byte in nil) while byte collect byte))) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; some Lisps will signal an error, some won't: (with-open-file (out "/tmp/data" :direction :output :if-exists :supersede :element-type '(mod 16)) (write-byte 16 out)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see C program "data.c" in this directory (rename-package :binary-types :bt) (bt:define-binary-class data-point () ((tag :accessor tag :binary-type bt:char8) ;; see remark about padding above (padding-1 :binary-type 1) (x0 :accessor x0 :binary-type bt:u16) (y0 :accessor y0 :binary-type bt:u16) ;; see above (padding-2 :binary-type 2) (size :accessor size :binary-type bt:s32) ;; so that size is 16 octets (padding-3 :binary-type 4))) (defmethod print-object ((data-point data-point) stream) (print-unreadable-object (data-point stream :type t) (with-accessors ((tag tag) (x0 x0) (y0 y0) (size size)) data-point (format stream "Tag: ~S, " tag) (format stream "X0: ~S, " x0) (format stream "Y0: ~S, " y0) (format stream "Size: ~S" size)))) (let ((bt:*endian* :little-endian)) (bt:with-binary-file (in "/tmp/data") (values (bt:read-binary 'data-point in) (bt:read-binary 'data-point in)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see C program "fdata.c" in this directory (with-open-file (in "/tmp/data" :element-type '(unsigned-byte 64)) (loop repeat 2 collect (ieee-floats:decode-float64 (read-byte in)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/data" :direction :output :element-type '(signed-byte 32)) (loop for i below 1000 do (write-byte (* i i) out))) (with-open-file (in "/tmp/data" :element-type '(signed-byte 32)) (file-position in 333) (values (read-byte in) (file-position in))) (* 333 333) (with-open-file (out "/tmp/data.txt" :direction :output) (write-string "Now, fair Hippolyta, our nuptial hour Draws on apace; four happy days bring in Another moon: but, O, methinks, how slow This old moon wanes! she lingers my desires, Like to a step-dame or a dowager Long withering out a young man revenue." out)) "Now, fair Hippolyta, our nuptial hour Draws on apace; four happy days bring in Another moon: but, O, methinks, how slow This old moon wanes! she lingers my desires, Like to a step-dame or a dowager Long withering out a young man revenue." (with-open-file (in "/tmp/data.txt") (file-position in 190) (let ((string (make-string 7))) (read-sequence string in) (values string (file-position in)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/data.txt" :direction :output :if-exists :supersede) (write-string "The present day sysadmin refuses to die." out)) (file-at-once "/tmp/data.txt") (with-open-file (out "/tmp/data.txt" :direction :output :if-exists :overwrite) (file-position out 16) (write-string "composer" out) (file-position out :end) (write-string " (Edgar Varese)" out)) (file-at-once "/tmp/data.txt") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun file-position* (stream &optional (pos nil pos-provided-p)) (cond ((not pos-provided-p) (file-position stream)) ((and (integerp pos) (< pos 0)) (file-position stream (+ (file-length stream) pos))) (t (file-position stream pos)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; external format is specific to AllegroCL (with-open-file (in "/tmp/test.txt" :external-format '(:e-crlf :latin1)) (loop for line = (read-line in nil) while line collect line)) (with-open-file (in "/tmp/test.txt" :external-format '(:e-crlf :latin1)) (let ((line (read-line in))) (values (length line) (file-position in)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/store" :direction :output) (print #\x out) (print 42 out) (print 'foo out) (print (* 2 pi) out) (print "Zoot Allures" out) (print (loop for i below 10 collect i) out)) (with-open-file (in "/tmp/store") (loop with eof = (gensym) for object = (read in nil eof) until (eq object eof) collect object)) (file-at-once "/tmp/store") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun circle-test () (let* ((a (list 1 2 3)) (b (cons 0 a))) (with-open-file (out "/tmp/store" :direction :output :if-exists :supersede) (print (list a b) out)) (with-open-file (in "/tmp/store") (let* ((c (read in)) (a% (first c)) (b% (second c))) (format t "Read ~S and ~S~%" a% b%) (values (eq a (cdr b)) (eq a% (cdr b%))))))) (circle-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (let ((*print-circle* t)) (circle-test)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; not all implementations will signal an error here (let ((*print-readably* t)) (print (make-hash-table))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun print-eql-hash-table (hash-table &optional (stream *standard-output*)) (format stream "#.") (pprint `(let ((new-hash-table (make-hash-table))) ,@(loop for key being the hash-keys of hash-table using (hash-value value) collect `(setf (gethash ',key new-hash-table) ',value)) new-hash-table) stream)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *h* (make-hash-table)) (setf (gethash 13 *h*) 42) (setf (gethash 'foo *h*) 'bar) (print-equal-hash-table *h*) (defparameter *h2* (read-from-string (with-output-to-string (out) (print-equal-hash-table *h* out)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ql:quickload "trivial-gray-streams") (use-package :trivial-gray-streams) (defclass my-vector-stream (fundamental-binary-input-stream) ((vector :initarg :vector) (index :initform 0))) (defmethod stream-read-byte ((stream my-vector-stream)) (with-slots (index vector) stream ;; return one byte or the keyword :EOF (cond ((< index (length vector)) (prog1 (aref vector index) ;; move "position within stream" (incf index))) (t :eof)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *in* (make-instance 'my-vector-stream :vector #(42 43 44 45 46 47))) (list (read-byte *in*) (let ((list (make-list 3))) (read-sequence list *in*) list) (read-byte *in*) (streamp *in*) (open-stream-p *in*)) (progn (read-byte *in*) (read-byte *in*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass my-dupe-stream (fundamental-character-output-stream) ()) (defmethod stream-write-char ((stream my-dupe-stream) char) (write-char char) (unless (char-equal char #\Newline) (write-char char))) (defparameter *out* (make-instance 'my-dupe-stream)) (print 42 *out*) (format *out* "~R~%" 42) (write-string "cooeeing" *out*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-15 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-15/foo.lisp][foo]] #+BEGIN_SRC lisp (defparameter *foo* *load-pathname*) ;; remove comment, then delete FASL: ;; (defparameter *bar* *compile-file-pathname*) ;; alternative, see book: ;; (eval-when (:compile-toplevel) ;; (defparameter *bar* *compile-file-pathname*)) #+END_SRC ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-15/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*default-pathname-defaults* (probe-file "passwd") (let ((*default-pathname-defaults* #p"/etc/")) (probe-file "passwd")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/foo.txt" :direction :output :if-exists :supersede) (write-string "42" out)) (probe-file #p"foo") (let ((*default-pathname-defaults* #p"/tmp/whatever.txt")) (probe-file #p"foo")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (pathname-type #p"foo") (let ((*default-pathname-defaults* #p"/tmp/whatever.txt")) (probe-file (make-pathname :name "foo" :type :unspecific))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (probe-file "/tmp/foo") (with-open-file (s "/tmp/foo" :direction :output) (write-string "bla" s)) (probe-file "/tmp/foo") (ensure-directories-exist (make-pathname :directory '(:absolute "tmp" "bar"))) (probe-file *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (directory "/tmp/foo*") (with-open-file (s "/tmp/foo2" :direction :output) (write-string "bla" s)) (directory "/tmp/foo*") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ensure-directories-exist "/tmp/foo/bar/") (ensure-directories-exist "/tmp/foo/bar/baz/frob" :verbose t) (ensure-directories-exist "/tmp/foo/bar/baz/frob" :verbose t) (ensure-directories-exist "/tmp/foo/bar/baz/frob/" :verbose t) ;; this will only work on AllegroCL (excl:make-directory "/tmp/bar" #o700) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ensure-directories-exist (make-pathname :directory '(:absolute "tmp" "foo" "bar" "baz" "frob") :name "dummy")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (directory (make-pathname :name :wild :type :wild :directory '(:absolute "tmp" "foo"))) (directory (make-pathname :name :wild :type "lisp" :directory '(:absolute "tmp" "foo"))) (directory (make-pathname :name "a" :type :wild :directory '(:absolute "tmp" "foo"))) (directory "/tmp/foo/*.lisp") (directory "/tmp/foo/a.*") (directory "/tmp/foo/*") (directory "/tmp/foo/*.*") (directory "/tmp/foo/ba*.lisp") (directory (make-pathname :name "ba*" :type :wild :directory "/tmp/foo/")) (directory (make-pathname :name "ba?" :type :wild :directory "/tmp/foo/")) (directory (make-pathname :name "*b*" :type :wild :directory "/tmp/foo/")) (directory "/tmp/foo/b*.lisp") (directory "/tmp/foo/b*.*") (directory "/tmp/foo/b??.lisp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (directory (make-pathname :directory '(:absolute "tmp" "foo" :wild "baz") :name :wild :type :wild)) (directory (make-pathname :directory '(:absolute "tmp" "foo" :wild "baz") :name "frob*" :type :wild)) (directory (make-pathname :directory '(:absolute "tmp" "foo" :wild :wild) :name "frob*" :type :wild)) (directory "/tmp/foo/*/baz/*") (directory "/tmp/foo/*/baz/frob*") (directory "/tmp/foo/*/*/frob*") (directory "/tmp/foo/bar*/baz/frob*") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (directory (make-pathname :directory '(:absolute "tmp" "foo" :wild-inferiors) :name "frob*" :type :wild)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun split-pathspec (pathspec) (values (directory-namestring pathspec) (file-namestring pathspec))) (split-pathspec #p"/etc/passwd") (split-pathspec #p"/usr/local/lib/") (split-pathspec #p"/usr/lib/libc.so") (probe-file #p"foo.doc") (split-pathspec #p"foo.doc") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (pathname-type #p"libc.so") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (pathname-type #p"foo.tar.gz") (pathname-type #p".bashrc") (pathname-type #p"foo.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ensure-directories-exist "/tmp/foo/dummy.txt") (directory "/tmp/foo/*.*") (with-open-file (s "/tmp/foo/a.txt" :direction :output)) (directory "/tmp/foo/*.*") (rename-file "/tmp/foo/a.txt" "/tmp/foo/b.txt") (directory "/tmp/foo/*.*") (rename-file "/tmp/foo/b.txt" "c.txt") (directory "/tmp/foo/*.*") (rename-file "/tmp/foo/c.txt" "d") (directory "/tmp/foo/*.*") (rename-file "/tmp/foo/d.txt" (make-pathname :type "lisp")) (directory "/tmp/foo/*.*") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (directory "/tmp/foo/*.*") (excl.osi:rename "/tmp/foo/a.txt" "/tmp/foo/b") (directory "/tmp/foo/*.*") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (rename-file "foo/a.txt" "bar/b.txt") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (probe-file "foo.lisp") (delete-file "foo.lisp") (probe-file "foo.lisp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; this example will only work with AllegroCL (defun delete-files (pathspec) (dolist (pathname (directory pathspec)) (unless (excl:file-directory-p pathname) (delete-file pathname)))) (directory #p"bar*" :directories-are-files nil) (delete-files #p"bar*") (directory #p"bar*" :directories-are-files nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (probe-file #p"foo.txt") (with-open-file (out #p"foo.txt" :direction :output) (values (probe-file #p"foo.txt") (probe-file out) (progn (delete-file out) (probe-file #p"foo.txt")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; example for AllegroCL (directory "/tmp/foo/*.*") (excl:delete-directory "/tmp/foo") (directory "/tmp/bar/*.*") (excl:delete-directory "/tmp/bar") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun copy-file (from to) (let* ((element-type '(unsigned-byte 8)) (buffer (make-array 8192 :element-type element-type))) (with-open-file (in from :element-type element-type) (with-open-file (out to :element-type element-type :direction :output :if-exists :supersede) (loop (let ((position (read-sequence buffer in))) (when (zerop position) (return)) (write-sequence buffer out :end position))) (pathname out))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((tex-counter 0) (sty-counter 0)) (fad:walk-directory "C:/Users/edi/Documents/MiKTeX/" (lambda (pathname) (let ((type (pathname-type pathname))) (cond ((string-equal type "tex") (incf tex-counter)) ((string-equal type "sty") (incf sty-counter)))))) (list tex-counter sty-counter)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((tex-counter 0)) (fad:walk-directory "C:/Users/edi/Documents/MiKTeX" (lambda (pathname) (declare (ignore pathname)) (incf tex-counter)) :test (lambda (pathname) (string-equal (pathname-type pathname) "tex"))) tex-counter) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (in "/etc/passwd") (pathname in)) (let ((in (open "/etc/passwd"))) (close in) (pathname in)) (pathname *standard-output*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((pathname (pathname "/etc/passwd"))) (with-open-file (in pathname) (eq pathname (pathname in)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see shell script "prepare.sh" in this directory (pathname "/tmp/foo.txt") (pathname "/tmp/bar.txt") (truename "/tmp/bar.txt") (probe-file "/tmp/quux.txt") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (directory "/tmp/*.txt") (directory "/tmp/*.txt" :resolve-symlinks nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see shell script "prepare2.sh" in this directory (truename "/tmp/quux/..") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (truename (make-pathname :directory (list :absolute "tmp" "quux" :up))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (truename (make-pathname :directory (list :absolute "tmp" "quux" :back))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "foo.lisp" in this directory (load (compile-file "foo.lisp")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; make modifications in "foo.lisp", then again... (load (compile-file "foo.lisp")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (logical-pathname-translations "STUFF") '(("SOURCE;**;*.*" "D:\\Dev\\**\\*.*") ("RESOURCES;**;*.JPG" "\\\\data.quux.com\\**\\pics\\*.jpg") ("RESOURCES;**;*.*" "\\\\data.quux.com\\**\\*.*"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (logical-pathname-translations "STUFF") '(("SOURCE;**;*.*" "/usr/local/lisp/**/*.*") ("RESOURCES;**;BACKUP;**;*.*" "/mnt/bak/**/**/*.*") ("RESOURCES;**;*.*" "~/data/**/*.*"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-16 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-16/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *quux* 42) (defun foo (x) (let ((*quux* 23)) (bar (1- x) *quux*))) (defun bar (a b) (declare (optimize debug)) (let ((c (* b b))) (catch 'tag (baz c a)))) (defun baz (v w) (/ v w)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (invoke-debugger (make-condition 'type-error :expected-type 'fixnum :datum 42.0)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (error 'type-error :expected-type 'fixnum :datum 42.0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((*break-on-signals* 'type-error)) (signal 'type-error :expected-type 'fixnum :datum 42.0)) (let ((*break-on-signals* 'arithmetic-error)) (ignore-errors (error 'division-by-zero :operands (list 42 0) :operation '/))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (catch 'tag (let ((*debugger-hook* (lambda (condition old-debugger-hook) (declare (ignore old-debugger-hook)) (format *error-output* "Condition ~S was suppressed.~%" condition) (throw 'tag 42)))) (error "Some error."))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (block my-block (handler-bind ((error (lambda (condition) (return-from my-block (trivial-backtrace:print-backtrace condition :output nil))))) (foo 1))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun female (n) (cond ((zerop n) 1) (t (- n (male (female (1- n))))))) (defun male (n) (cond ((zerop n) 0) (t (- n (female (male (1- n))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (trace male) (male 3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (trace female) (male 3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (trace) ;; which functions are currently traced (untrace male) ;; stop tracing MALE (trace) ;; check again (untrace) ;; untrace ALL functions (trace) ;; check again (female 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo (a) (declare (optimize debug)) (let* ((b (random 5)) (c (expt a b))) (- c a))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (step (foo 3)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar foo 42 "A variable with the same name as the function FOO.") (defun foo (x y) "Computes the BAR of X and Y and binds FOO." (let ((foo 23)) (bar x y))) (defun bar (a b) "Computes FLOOR after switching the arguments." (floor b a)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (documentation 'foo 'function) (documentation 'foo 'variable) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf (logical-pathname-translations "SYS") '(("SYS:SRC;**;*.*.*" #p"/opt/sbcl-1.2.13/src/**/*.*") ("SYS:CONTRIB;**;*.*.*" #p"/opt/sbcl-1.2.13/contrib/**/*.*"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (describe (make-condition 'type-error :expected-type 'string :datum #\X)) (describe (let ((hash-table (make-hash-table))) (setf (gethash 42 hash-table) 23) hash-table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *thing* (vector :lp (list 20 "Hotels") 1971)) (inspect *thing*) ,*thing* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (apropos "odd") (apropos :odd :cl) (apropos-list "odd" :cl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ppcre:regex-apropos "lo.*lo.*la" :cl) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-add (x) (+ x x)) (fmakunbound 'my-add) (my-add 3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-add (x) (+ x x)) (defparameter my-add-fn #'my-add) (fmakunbound 'my-add) (funcall my-add-fn 21) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *foo* 42) (makunbound '*foo*) ,*foo* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod my-length ((x list)) (length x)) (defmethod my-length ((x symbol)) (length (symbol-name x))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (find-method #'my-length nil '(list)) (remove-method #'my-length *) (my-length 'foo) (my-length '(f o o)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass my-class () ((a :initform 42 :reader a))) (defvar *a* (make-instance 'my-class)) (find-class 'my-class) (setf (find-class 'my-class) nil) (make-instance 'my-class) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above ,*a* (class-of *) (a *a*) (make-instance **) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *foo* 42) ;; (PROGN ;; (SYSTEM::UNPROCLAIM '(SPECIAL *FOO*)) ;; (MAKUNBOUND '*FOO*)) (defun my-add (x) (+ x x)) ;; (WHEN-LET (SYSTEM::REAL-SPEC (DSPEC:DSPEC-DEFINED-P '#'MY-ADD)) ;; (EVAL (DSPEC:DSPEC-UNDEFINER SYSTEM::REAL-SPEC))) (defmethod my-length ((x list)) (length x)) ;; (CLOS::UNDEFMETHOD MY-LENGTH (LIST)) (define-condition my-error (error) ()) ;; (CLOS::UNDEFCLASS MY-ERROR) (defclass my-class () ((a :initform 42 :reader a))) ;; (CLOS::UNDEFCLASS MY-CLASS) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo (x) x) (trace foo) (with-output-to-string (*standard-output*) (with-input-from-string (*standard-input* (format nil "n~%")) (print (y-or-n-p "Do You Like My New Car?")) (foo 42) (warn "Achtung!") (print (read)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (list *standard-output* *standard-input*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (floor 42 4) :foo (parse-integer "42 ") (list * ** *** / // /// + ++ +++ -) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -3/4 (* 5 *) (* ** **) (+ * ** -3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (handler-case (delete-file "/tmp/my-dribble") (file-error ())) (dribble "/tmp/my-dribble") (+ 40 2) (print *) (dribble) (with-open-file (in "/tmp/my-dribble") (loop for line = (read-line in nil) while line do (format t "DRIBBLE: ~A~%" line))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-17 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-17/foo.lisp][foo]] #+BEGIN_SRC lisp (defpackage :foo (:use :cl) (:export :main)) (in-package :foo) (defun foo-1 (n) (loop for i below (* 1000 n) maximize i)) (defun foo-2 (n) (loop for i below n sum i)) (defun foo-3 (n) (loop for i below n sum (foo-2 i))) (defun bar-1 (n) (loop for i below n sum (foo-1 i))) (defun bar-2 (n) (loop for i below n sum (foo-3 i))) (defun baz-1 (n) (bar-2 (* 10 n))) (defun baz-2 (n) (if (zerop n) (baz-1 1) (+ (bar-1 n) (baz-2 (1- n))))) (defun main (n) (loop for i below n sum (+ (baz-1 i) (baz-2 i)))) #+END_SRC ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-17/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun sum (n) (loop for i from 1 to n sum i)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun sum (n) (* 1/2 n (1+ n))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "foo.lisp" in this directory (time (foo:main 40)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (profile "FOO") (profile) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (profile foo::foo-3 foo::bar-2 foo::foo-1 foo::foo-2 foo::baz-1 foo::baz-2 foo::bar-1 foo:main) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (foo:main 40) (report) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (unprofile "FOO") (profile) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require :sb-sprof) (sb-sprof:with-profiling (:report :flat) (foo:main 40)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :cl-user) (defvar *l* (loop repeat 10000000 collect (random 1d0))) (defun test-1 () (let ((result 0)) (map nil (lambda (x) (incf result (* 2d0 x))) *l*) result)) (defun test-2 () (declare (optimize speed)) (let ((result 0)) (map nil (lambda (x) (incf result (* 2d0 x))) *l*) result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (test-1)) (time (test-2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (test-1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :cl-user) (defconstant +max+ 10000000) (defvar *a* (make-array +max+ :initial-contents (loop repeat +max+ collect (random 1d0)))) (defun test-1 (max) (loop for i below max sum (aref *a* i))) (defun test-2 (max) (declare (optimize (safety 0))) (loop for i below max sum (aref *a* i))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun array-sum (array) (loop for i below (length array) sum (aref array i))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun array-sum (array) (declare (optimize speed)) ; <-- THIS LINE WAS ADDED (loop for i below (length array) sum (aref array i))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun array-sum (array) (declare (:explain :types)) ;; <- for LispWorks or AllegroCL (loop for i below (length array) sum (aref array i))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo-1 (x) (let ((result 0)) (dotimes (i 100000000) (incf result x)) result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo-2 (x) (declare (double-float x)) ;; <-- ADDED (let ((result 0d0)) ;; <-- CHANGED (dotimes (i 100000000) (incf result x)) result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo-3 (x) (declare (optimize speed) ;; <-- ADDED (double-float x)) (let ((result 0d0)) (dotimes (i 100000000) (incf result x)) result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo-4 (x) (declare (optimize speed) (double-float x)) (let ((result 0d0)) (declare (double-float result)) ;; <-- ADDED (dotimes (i 100000000) (incf result x)) result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (foo-4 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo-5 (x) (declare (optimize speed (safety 0)) ;; <-- ADDED (double-float x)) (let ((result 0d0)) (declare (double-float result)) (dotimes (i 100000000) (incf result x)) result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (foo-5 42) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun matching-p (edges) (let ((hash (make-hash-table))) (loop for (vertex-1 vertex-2) in edges when (or (gethash vertex-1 hash) (gethash vertex-2 hash)) do (return-from matching-p nil) else do (setf (gethash vertex-1 hash) t (gethash vertex-2 hash) t)) t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *edges* (cons (list 99999 100000) (loop for i below 100000 by 2 collect (list i (1+ i))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((hash (make-hash-table))) ;; <-- now outside of the function (defun matching-p (edges) ;; the following initialization loop is new (loop for vertex being the hash-keys of hash do (setf (gethash vertex hash) nil)) ;; the rest is exactly as above (loop for (vertex-1 vertex-2) in edges when (or (gethash vertex-1 hash) (gethash vertex-2 hash)) do (return-from matching-p nil) else do (setf (gethash vertex-1 hash) t (gethash vertex-2 hash) t)) t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *l* (loop for i below 20 collect i)) (defun foo-1 (list n) (let ((dummy list)) (dotimes (i n) (setf dummy (reverse dummy))) dummy)) (defun foo-2 (list n) (let ((dummy list)) (dotimes (i n) (setf dummy (nreverse dummy))) ;; <-- note the "N" here dummy)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*l* (time (foo-1 *l* 99999999)) ,*l* (time (foo-2 *l* 99999999)) ,*l* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (nreverse *l*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setf *l* (nreverse *l*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for i below 100000 sum (/ 1 (expt 1.0001d0 i))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun do-something (pair) (+ (first pair) (* 2 (second pair)))) (defun foo (list-1 list-2) (loop for a in list-1 for b in list-2 sum (do-something (list a b)))) ;; does the same as FOO (defun bar (list-1 list-2) (loop for a in list-1 for b in list-2 sum (let ((x (list a b))) (declare (dynamic-extent x)) (do-something x)))) ;; random test data (defvar *l-1* (loop for i below 1000000 collect (random 100))) (defvar *l-2* (loop for i below 1000000 collect (random 100))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (foo *l-1* *l-2*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (bar *l-1* *l-2*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun three-1 () (list (random 100) (random 100) (random 100))) (defun three-2 () (values (random 100) (random 100) (random 100))) ;; just to make results comparable (defvar *r* (make-random-state t)) (defun test-1 (n) (setf *random-state* (make-random-state *r*)) (let ((result 0)) (dotimes (i n result) (destructuring-bind (x y z) (three-1) (incf result (min x y z)))))) (defun test-2 (n) (setf *random-state* (make-random-state *r*)) (let ((result 0)) (dotimes (i n result) (multiple-value-bind (x y z) (three-2) (incf result (min x y z)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (test-1 1000000)) (time (test-2 1000000)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun member* (elt list) (cond ((null list) nil) ((eql (first list) elt) list) (t (member* elt (rest list))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (member* 42 (make-list 10000 :initial-element 41)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun member* (elt list) (loop for rest on list when (eql (first rest) elt) do (return rest))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod apply-transform ((transform number) vector) (* transform vector)) (defmethod apply-transform ((transforms list) vector) (apply-transform (compound-transform transforms) vector)) (defun compound-transform (transforms) ;; or use REDUCE (let ((compound-transform 1)) (dolist (transform transforms) (setf compound-transform (* transform compound-transform))) compound-transform)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (apply-transform '(1 2 3 4 5) vector) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (apply-transform 120 vector) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-compiler-macro apply-transform (&whole form &environment env transform vector) (cond ((and (constantp transform env) (listp transform)) `(apply-transform (load-time-value (compound-transform ,transform)) ,vector)) (t form))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (trace compound-transform) (defun foo (vector) (apply-transform '(1 2 3 4 5) vector)) (foo 10) (compile 'foo) (foo 10) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun fib (n) (if (<= n 1) 1 (+ (fib (- n 2)) (fib (- n 1))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (fib 42)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((hash (make-hash-table))) (defun fib* (n) (or (gethash n hash) (setf (gethash n hash) ;; below is the original algorithm (if (<= n 1) 1 (+ (fib* (- n 2)) (fib* (- n 1)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (fib* 42)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (fare-memoization:memoize 'fib) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declaim (inline bar)) ;; <- see (a) in book (defun bar (i) (declare (optimize speed) (double-float i)) (let ((j (+ i 1d0))) (sqrt (+ (* i i) (* j j))))) (declaim (notinline bar)) ;; <- see (b) in book (defun foo-1 () (declare (optimize speed)) (let ((x 0d0) (i 1d0)) (declare (double-float x)) (loop (unless (< i 100000000d0) (return x)) (incf x (the double-float (bar i))) (incf i 1d0)))) (defun foo-2 () (declare (optimize speed) (inline bar)) ;; <- see (c) in book (let ((x 0d0) (i 1d0)) (declare (double-float x)) (loop (unless (< i 100000000d0) (return x)) (incf x (bar i)) ;; <- one declaration less (incf i 1d0)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (foo-1)) (time (foo-2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo-1 () (flet ((bar (i) (sqrt (+ (* i i) (* i i))))) (loop for k below 42 collect (bar k)))) ;; (A) (defun foo-2 () (flet ((bar (i) (sqrt (+ (* i i) (* i i))))) (loop for k below 42 collect (+ (bar k) (bar (+ k 1)))))) ;; (B) (defun foo-3 () (flet ((bar (i) (sqrt (+ (* i i) (* i i))))) (declare (inline bar)) (loop for k below 42 collect (+ (bar k) (bar (+ k 1)))))) ;; (C) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun dot-product-1 (x-1 x-2 y-1 y-2) (+ (* x-1 y-1) (* x-2 y-2))) (defun dot-product-2 (x-1 x-2 y-1 y-2) (declare (optimize (safety 2) (hcl:fixnum-safety 0))) (+ (* x-1 y-1) (* x-2 y-2))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (disassemble 'dot-product-1) (disassemble 'dot-product-2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconstant +max+ 10000000) (defvar *a* (let ((a (make-array +max+ :element-type 'double-float))) (dotimes (i +max+) (setf (aref a i) (random 1d0))) a)) (defun foo-1 (a) (let ((result 1d0)) (declare (double-float result)) (dotimes (i +max+) (incf result (the double-float (aref a i)))) result)) (defun foo-2 (a) (declare (type (simple-array double-float (*)) a)) (let ((result 1d0)) (declare (double-float result)) (dotimes (i +max+) (incf result (aref a i))) result)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time (foo-1 *a*)) (time (foo-2 *a*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-18 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-18/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require :asdf) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (quicklisp-quickstart:install) (ql:add-to-init-file) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ql:quickload "quickproject") (quickproject:make-project "/tmp/fnork/" :depends-on '(drakma lparallel)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (alexandria:plist-hash-table '(batman gotham-city superman metropolis spider-man new-york-city) :test 'eq) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (alexandria:when-let (symbol (find-symbol "LET")) (symbol-package symbol)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((mod3 (alexandria:rcurry 'mod 3))) (funcall mod3 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *a* (list 1 2 3 4 5)) (alexandria:appendf *a* (list 6 7 9)) ,*a* (setf (alexandria:lastcar *a*) 8) ,*a* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (alexandria:shuffle (list 1 2 3 4 5 6)) (alexandria:map-combinations (lambda (subseq) (format t "~{~A~^-~}~%" subseq)) '(1 2 3 4 5) :length 3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (alexandria:lerp 1/10 40 60) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ppcre:scan "([aeiou])\\1" "This example is too simple and cheesy.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (pprint (ppcre:parse-string "([a-z])|42+")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ppcre:scan "a|b+" string) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun foo-1 (regex) (dotimes (i 100000) (ppcre:scan regex "Frunobulax"))) (defun foo-2 () (dotimes (i 100000) (ppcre:scan "a|b+" "Frunobulax"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ppcre:scan-to-strings "([aeiou])\\1" "This example is too simple and cheesy.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ppcre:all-matches-as-strings "([aeiou])\\1" "This example is too simple and cheesy.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun digital-root-1 (target-string) (let ((sum 0)) (ppcre:do-matches-as-strings (match :digit-class target-string) (incf sum (parse-integer match))) (if (< sum 10) sum (digital-root-1 (princ-to-string sum))))) (defun digital-root-2 (target-string) (let ((sum 0)) (ppcre:do-matches (start end :digit-class target-string) (incf sum (parse-integer target-string :start start :end end))) (if (< sum 10) sum (digital-root-2 (princ-to-string sum))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ppcre:split "\\W+" "The quick brown fox jumps over the lazy dog.") (ppcre:regex-replace-all "[aeiou]" "foul" "e") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (drakma:http-request "http://weitz.de/erdos.html") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-file (out "/tmp/lisp_logo.jpg" :element-type '(unsigned-byte 8) :direction :output) (cl-fad:copy-stream (flexi-streams:flexi-stream-stream (drakma:http-request "http://weitz.de/regex-coach/lisp_logo.jpg" :want-stream t)) out)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cl-html-parse:parse-html (drakma:http-request "http://lisp.org")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 4242)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (hunchentoot:define-easy-handler (test-handler :uri "/test") ((name :init-form "Pumpkin")) (format nil " Common Lisp Recipes Yo, ~A! The Lisp time is ~A." name (get-universal-time))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-other-handler () " Common Lisp Recipes I'm a constant string.") (push (hunchentoot:create-prefix-dispatcher "/foo" 'my-other-handler) hunchentoot:*dispatch-table*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-other-handler () (format nil " Common Lisp Recipes I'm not a constant string.
And these were the GET parameters:~{ ~S~}." (hunchentoot:get-parameters*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ql:quickload "hunchentoot-test") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-other-handler () (let ((template " Common Lisp Recipes I'm not a constant string.
And these were the GET parameters: ")) (clip:process-to-string template :params (hunchentoot:get-parameters*)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun my-other-handler () (cl-markup:html5 (:title "Common Lisp Recipes") (:body "I'm not a constant string." (:br) "And these were the GET parameters: " (loop for param in (hunchentoot:get-parameters*) collect (cl-markup:markup (:span (prin1-to-string param)))) "."))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-19 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-19/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "test.c" in this directory (cffi:load-foreign-library "/tmp/test.so") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:foreign-funcall "power" :double 1.4142135623730951d0 :int 2 :double) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:defcfun "power" :double (base :double) (exponent :int)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (power 2.5457298950218306d0 4) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:foreign-funcall "hypot" :double 3d0 :double 4d0 :double) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see files "test.c" and "test2.c" in this directory (cffi:load-foreign-library "/tmp/test.so") (cffi:load-foreign-library "/tmp/test2.so") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:define-foreign-library test-lib (t "/tmp/test.so")) (cffi:load-foreign-library 'test-lib) (cffi:defcfun ("power" :library test-lib) :double (base :double) (exponent :int)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:define-foreign-library other-test-lib (t "/tmp/test2.so")) (cffi:load-foreign-library 'other-test-lib) (cffi:defcfun ("power" one-arg-power :library other-test-lib) :double (exponent :int)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "swap.c" in this directory (cffi:defcfun swap :void (a :pointer) (b :pointer)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *a* (cffi:foreign-alloc :int)) ,*a* (cffi:mem-ref *a* :int) (setf (cffi:mem-ref *a* :int) 42) (cffi:mem-ref *a* :int) (defparameter *b* (cffi:foreign-alloc :int :initial-element 23)) (cffi:mem-ref *b* :int) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (swap *a* *b*) (list (cffi:mem-ref *a* :int) (cffi:mem-ref *b* :int)) (cffi:foreign-free *a*) (cffi:foreign-free *b*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:with-foreign-objects ((a :int) (b :int)) (setf (cffi:mem-ref a :int) 42 (cffi:mem-ref b :int) 23) (print (list (cffi:mem-ref a :int) (cffi:mem-ref b :int))) (swap a b) (list (cffi:mem-ref a :int) (cffi:mem-ref b :int))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:defcfun swap :void (a (:pointer :int)) (b (:pointer :int))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:with-foreign-objects ((a :int) (b :double)) (setf (cffi:mem-ref a :int) 42 (cffi:mem-ref b :double) 23d0) (print (list (cffi:mem-ref a :int) (cffi:mem-ref b :double))) (swap a b) (list (cffi:mem-ref a :double) (cffi:mem-ref b :int))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *test* (cffi:foreign-alloc :short :initial-contents (list 42 23))) (cffi:foreign-type-size :short) (cffi:foreign-type-size :float) (list (cffi:mem-ref *test* :short) (cffi:mem-ref *test* :short 2) ;; *TEST* + 2 (octets) (cffi:mem-ref *test* :float)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "swap.c" in this directory (fli:register-module 'foo :real-name "/tmp/foo.so") (fli:define-foreign-function swap ((a (:pointer :int)) (b (:pointer :int))) :module 'foo :result-type :void) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (fli:with-dynamic-foreign-objects ((a :int :initial-element 42) (b :int :initial-element 23)) (swap a b) (list (fli:dereference a) (fli:dereference b))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (fli:with-dynamic-foreign-objects ((a :int :initial-element 42) (b :double :initial-element 23d0)) (swap a b) (list (fli:dereference a) (fli:dereference b))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "sum.c" in this directory (cffi:defcfun sum :double (arr :pointer) (size :int)) (defparameter *arr* (cffi:foreign-alloc :double :initial-contents (loop for x from 1 to 10 collect (float x 1d0)))) (cffi:mem-aref *arr* :double 3) (sum *arr* 10) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "sum.c" in this directory (cffi:defcfun "set_arr" :double (arr :pointer) (index :int) (new-value :double)) (cffi:mem-aref *arr* :double 7) (set-arr *arr* 7 42d0) (cffi:mem-aref *arr* :double 7) ;; don't forget this! (cffi:foreign-free *arr*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *arr* (make-array 10 :element-type 'double-float :initial-contents (loop for x from 1d0 to 10d0 by 1d0 collect x) :allocation :static)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (fli:define-foreign-function sum ((arr :lisp-array) (size :int)) :result-type :double :module 'foo) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ,*arr* (aref *arr* 5) (sum *arr* (length *arr*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "complex.c" in this directory (cffi:defcstruct c-complex (real :double) (imag :double)) (cffi:defcfun "magnitude_squared" :double (c :pointer)) (cffi:with-foreign-object (c '(:struct c-complex)) (setf (cffi:foreign-slot-value c '(:struct c-complex) 'real) 3d0 (cffi:foreign-slot-value c '(:struct c-complex) 'imag) 4d0) (sqrt (magnitude-squared c))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "factorial.c" in this directory (cffi:defcunion result-union (rval :double) (ival :unsigned-long)) (cffi:defcstruct result-struct (exact (:boolean :char)) (val (:union result-union))) (cffi:defcfun factorial :void (n :int) (r :pointer)) (defun fact (n) (cffi:with-foreign-object (r '(:struct result-struct)) (factorial n r) (let ((result-union (cffi:foreign-slot-value r '(:struct result-struct) 'val))) (if (cffi:foreign-slot-value r '(:struct result-struct) 'exact) (cffi:foreign-slot-value result-union '(:union result-union) 'ival) (cffi:foreign-slot-value result-union '(:union result-union) 'rval))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (fact 20) (fact 23) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; using RESULT-UNION from example above (defctype r-union (:union result-union)) (defcstruct result-struct (exact (:boolean :char)) (val r-union)) (defctype r-struct (:struct result-struct)) (defun fact (n) (with-foreign-object (r 'r-struct) (factorial n r) (let ((result-union (foreign-slot-value r 'r-struct 'val))) (if (foreign-slot-value r 'r-struct 'exact) (foreign-slot-value result-union 'r-union 'ival) (foreign-slot-value result-union 'r-union 'rval))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:foreign-alloc '(:struct c-complex)) (cffi:mem-ref * '(:struct c-complex)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "convert.c" in this directory (cffi:defcfun convert :void (in :string) (out :pointer)) (defun show (str) (cffi:with-foreign-object (arr :uint (* (length str) 2)) (convert str arr) (loop for i from 0 for c = (cffi:mem-aref arr :uint i) until (zerop c) collect c))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (show "Läther") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:defcfun convert :void (in (:string :encoding :latin-1)) (out :pointer)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (show "Läther") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (babel-encodings:list-character-encodings) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "callback.c" in this directory (cffi:defcallback print-hex :void ((n :int)) (format t "--> ~X" n)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:foreign-funcall test :int 32 :pointer (cffi:callback print-hex) :void) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun power (base exponent) (ffi:c-inline (base exponent) (:double :int) :double "{ int i; double result = 1.0; for (i = 1; i <= #1; i++) result *= #0; @(return) = result; }")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (power 1.4142135623730951d0 2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (power 2 10) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cffi:load-foreign-library "Compl.so") (cffi:load-foreign-library "Compl_wrap.so") (load (compile-file "compl.lisp")) (load (compile-file "compl-clos.lisp")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *c* (make-instance 'compl :r 3d0 :i 4d0)) (magnitude-squared *c*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ffi:load-foreign-library "/tmp/Compl.so") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ffi:clines "#include \"/tmp/Compl.h\"") (defun mag (real imag) (ffi:c-inline (real imag) (:double :double) :double "{ Compl c = Compl(#0, #1); @(return) = c.magnitude_squared(); }")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sqrt (mag 3 4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (jclass "java.util.TimeZone") (jmethod * "getTimeZone" "java.lang.String") (jstatic * ** "Europe/Berlin") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (jstatic "getTimeZone" "java.util.TimeZone" "Europe/Berlin") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (jnew "java.text.SimpleDateFormat" "yyyy-MM-dd'T'HH:mm'Z'") (jcall "setTimeZone" * **) (jcall "format" ** (jnew "java.util.Date")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require 'jlinker) (use-package :net.jlinker) (jlinker-init :jni) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((time-zone-class (jclass "java.util.TimeZone")) (time-zone (jstatic (jmethod time-zone-class "getTimeZone" "java.lang.String") time-zone-class "Europe/Berlin")) (date-format-class (jclass "java.text.SimpleDateFormat")) (date-format (jnew date-format-class "yyyy-MM-dd'T'HH:mm'Z'"))) (jcall "setTimeZone" date-format time-zone) (jcall (jmethod date-format-class "format" "java.util.Date") date-format (jnew "java.util.Date"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (jstatic "getTimeZone" "java.util.TimeZone" "Europe/Berlin") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require "java-interface") (use-package :lw-ji) (init-java-interface :jvm-library-path ;; where jvm.dll is (if not on PATH) "C:/Program Files/Java/jre1.8.0_31/bin/server/jvm.dll" ;; optional (for calling Lisp from Java) :java-class-path (namestring (lispworks-file "etc/lispcalls.jar"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (call-java-method "java.util.TimeZone.getTimeZone" "Europe/Berlin") (create-java-object "java.text.SimpleDateFormat" "yyyy-MM-dd'T'HH:mm'Z'") (call-java-method "java.text.SimpleDateFormat.setTimeZone" ,* **) (call-java-method "java.text.SimpleDateFormat.format" ,** (create-java-object "java.util.Date")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (call-java-method "getTimeZone" "Europe/Amsterdam") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (import-java-class-definitions "java.util.TimeZone") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-output-to-string (out) (write-java-class-definitions-to-stream "java.util.TimeZone" out)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; note that we use a string because it's lowercase (use-package "java.util") (timezone.gettimezone "Europe/Paris") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *counter* 0) become the "run" method below (defun add-something () (incf *counter* 42)) (compile *) (define-lisp-proxy proxy-example ;; the interface to implement ("java.lang.Runnable" ;; we could have more than one method here ("run" add-something))) (create-java-object "java.lang.Thread" ;; "instantiate" the proxy (make-lisp-proxy 'proxy-example)) ,*counter* (call-java-method "java.lang.Thread.start" **) ,*counter* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (yason:parse "1") (yason:parse "2.0") (yason:parse "\"I am a string\"") (yason:parse "null") (yason:parse "true") (yason:parse "false") (yason:parse "[1, 2.0, \"foo\", null, false]") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (yason:parse "{\"one\":1, \"two\": 2.0, \"three\":true}") (loop for key being the hash-keys of * using (hash-value value) collect (list key value)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((yason:*parse-json-booleans-as-symbols* t)) (yason:parse "true")) (let ((yason:*parse-json-arrays-as-vectors* t)) (yason:parse "[1, 2.0, \"foo\", null, false]")) (let ((yason:*parse-object-as* :alist)) (yason:parse "{one:1, two:2.0, \"three\":true}")) (let ((yason:*parse-object-as* :plist)) (yason:parse "{one:1, two:2.0, \"three\":true}")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (yason:encode 3) (yason:encode 3.141) (yason:encode t) (yason:encode nil) (yason:encode '(1 2 #(3 4))) (let ((hash (make-hash-table))) (setf (gethash "42" hash) "forty-two" (gethash "one" hash) '(42)) (yason:encode hash)) (yason:encode-alist '((:42 . 42) (:foo "foo"))) (yason:encode-plist '(:42 42 :foo "foo")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "note.xml" in this directory (cxml:parse #p"note.xml" (cxml-xmls:make-xmls-builder)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass my-handler (sax:default-handler) ((indentation :initform 0 :accessor indentation))) (defmethod sax:start-element ((handler my-handler) namespace-uri local-name qname attributes) (declare (ignore namespace-uri qname attributes)) (incf (indentation handler) 2) (format t "~VT~A~%" (indentation handler) local-name)) (defmethod sax:end-element ((handler my-handler) namespace-uri local-name qname) (declare (ignore namespace-uri qname)) (decf (indentation handler) 2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cxml:parse #p"note.xml" (make-instance 'my-handler)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (use-package :paiprolog) (<- (father anakin luke)) (<- (father anakin leia)) (<- (father luke ben)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (?- (father ?x leia)) (?- (father anakin ?x)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (<- (child ?x ?y) (father ?y ?x)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (?- (child ?z anakin)) (?- (child ?a ?b)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (<- (grand-child ?x ?z) (child ?x ?y) (child ?y ?z)) (?- (grand-child ?a anakin)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-20 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-20/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "index.html" in this directory (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :document-root "/path/to/gui/" :port 4242)) (hunchentoot:define-easy-handler (get-symbols :uri "/get-symbols") (term) (setf (hunchentoot:content-type*) "application/json") (with-output-to-string (*standard-output*) (yason:encode (sort (mapcar 'string-downcase (apropos-list term :cl)) 'string<)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *size* 400) (defun gui () (ltk:with-ltk () (let* ((vals (list 2 3 4)) (canvas (ltk:make-canvas nil :width *size* :height *size*)) (spinbox (make-instance 'ltk:spinbox :width 3 :command (lambda (val) (sierpinski canvas (parse-integer val))) :master nil :values vals :text (first vals)))) (ltk:wm-title ltk:*tk* "Sierpinski") (ltk:configure canvas :background :white) (ltk:pack canvas) (ltk:pack spinbox) (sierpinski canvas (first vals))))) (defun sierpinski (canvas level) (ltk:clear canvas) (labels ((square (x y size) (let ((rectangle (ltk:create-rectangle canvas x y (+ x size) (+ y size)))) (ltk:itemconfigure canvas rectangle :fill :red) (ltk:itemconfigure canvas rectangle :outline :red))) (recurse (x y size level) (let ((step (* 1/3 size))) (square (+ x step) (+ y step) step) (when (plusp level) (dolist (next-x (list x (+ x step) (+ x step step))) (dolist (next-y (list y (+ y step) (+ y step step))) (recurse next-x next-y step (1- level)))))))) (recurse 0 0 *size* level))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require 'abcl-contrib) (require 'jss) (use-package :jss) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun say-hello () (let ((frame (new 'JFrame "Hello ABCL")) (label (new 'JLabel "The crux of the biscuit is the apostrophe."))) (#"add" (#"getContentPane" frame) label) (#"pack" frame) (#"setVisible" frame t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (#"invokeLater" 'SwingUtilities (jinterface-implementation "java.lang.Runnable" "run" #'say-hello)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see Java files in this directory (add-to-classpath "/tmp/") (require 'abcl-contrib) (require 'jss) (use-package :jss) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *size* 400) (defun set-points (java-array) (loop for x from -2d0 to 1d0 by (/ 3d0 *size*) for i from 0 do (loop for y from 1.5d0 downto -1.5d0 by (/ 3d0 *size*) for j from 0 for c = (complex x y) when (loop repeat 100 for z = c then (+ (* z z) c) always (< (abs z) 2d0)) do (jarray-set java-array +true+ i j)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((mandelbrot (new "de.weitz.Mandelbrot" (jinterface-implementation "de.weitz.PointSetter" "fill" #'set-points) *size*))) (#"display" mandelbrot)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass node () ((value :initarg :value :reader value) (children :initform nil :accessor children))) (defmethod print-object ((node node) stream) (with-slots (value) node (format stream "~A/~A" (numerator value) (denominator value)))) (defmethod add-children ((node node)) (let* ((numerator (numerator (value node))) (denominator (denominator (value node))) (sum (+ numerator denominator))) (setf (children node) (list (make-instance 'node :value (/ numerator sum)) (make-instance 'node :value (/ sum denominator)))))) (defun one () (make-instance 'node :value 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (capi:define-interface calkin-wilf-tree () () (:panes (tree capi:tree-view :reader tree :roots (list (one)) :children-function #'children :action-callback (lambda (node interface) (unless (children node) (add-children node) (capi:tree-view-update-item (tree interface) node nil))) :action-callback-expand-p t) (reset-button capi:push-button :text "Reset" :callback-type :interface :callback (lambda (interface) (setf (capi:tree-view-roots (tree interface)) (list (one)))))) (:layouts (default-layout capi:column-layout '(tree reset-button) :adjust :center)) (:default-initargs :best-width 400 :best-height 400 :title "Calkin-Wilf Tree")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (capi:display (make-instance 'calkin-wilf-tree)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-21 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-21/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass quux () ((a :initarg :a :reader a))) (defpackage frob) (defparameter *thing* (let* ((list (list :foo)) (hash (make-hash-table))) (setf (gethash 42 hash) list) (vector #\x "x" (make-instance 'quux :a 42) (intern "X" :frob) list hash))) (cl-store:store *thing* "/tmp/store") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (defparameter *other-thing* (cl-store:restore "/tmp/store")) *other-thing* (eq (aref *other-thing* 4) (gethash 42 (aref *other-thing* 5))) (a (aref *other-thing* 2)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cl-store:restore "/tmp/store") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *thing* (let* ((list (list :foo)) (hash (make-hash-table))) (setf (gethash 42 hash) list) (vector (find-package :frob) (find-class 'quux) ;; <- added #\x "x" (make-instance 'quux :a 42) (intern "X" :frob) list hash))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (clsql:connect '("/tmp/worldcup.db") :database-type :sqlite3) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (clsql:def-view-class final () ((city :accessor city :initarg :city :type string) (year :accessor year :initarg :year :db-kind :key :type integer) (winner :accessor winner :initarg :winner :type keyword))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (clsql:create-view-from-class 'final) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (make-instance 'final :city "Rome" :year 1934 :winner :ita) (clsql:update-records-from-instance *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((clsql:*db-auto-sync* t)) (loop for (city year winner) in '(("Paris" 1938 :ita) ("Bern" 1954 :deu) ("Solna" 1958 :bra) ("Santiago" 1962 :bra) ("Mexico City" 1970 :bra) ("Munich" 1974 :deu) ("Madrid" 1982 :ita) ("Rome" 1990 :deu) ("Pasadena" 1994 :bra) ("Yokohama" 2002 :bra) ("Berlin" 2006 :ita) ("Rio" 2014 :deu)) for final = (make-instance 'final :city city :year year :winner winner) finally (return final))) ;; oh wait, we made a mistake in the last object; let's fix it: (let ((clsql:*db-auto-sync* t)) (setf (city *) "Rio de Janeiro")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (clsql:select 'final :flatp t) (describe (first (last *))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; this is for the [...] syntax used below (clsql:enable-sql-reader-syntax) (clsql:select 'final :where [= [city] "Rome"] :flatp t) (mapcar 'winner *) ;; now we lose the CLOS objects and read the data "directly" (clsql:select [winner] [count [*]] :from [final] :group-by [winner]) ;; you can also transmit SQL statements as strings if you prefer (clsql:query "select distinct winner from final") ;; various looping constructs are available (clsql:do-query ((winner) [select [distinct [winner]] :from [final]]) (princ winner)) ;; and even a modified LOOP (which will work in /some/ Lisps) (loop for winner being the records of [select [winner] :from [final]] count (string= ":ITA" winner)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass final (bknr.datastore:store-object) ((city :accessor city :initarg :city) (year :accessor year :initarg :year) (winner :accessor winner :initarg :winner)) (:metaclass bknr.datastore:persistent-class)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((object-subsystem (make-instance 'bknr.datastore:store-object-subsystem))) (make-instance 'bknr.datastore:mp-store :directory "/tmp/store/" :subsystems (list object-subsystem))) bknr.datastore:*store* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for (city year winner) in '(("Rome" 1934 :ita) ("Paris" 1938 :ita) ("Bern" 1954 :deu) ("Stockholm" 1958 :bra)) for final = (make-instance 'final :city city :year year :winner winner) finally (return final)) ;; Oops, let's fix that... (bknr.datastore:with-transaction () (setf (city *) "Solna")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (bknr.datastore:store-objects-with-class 'final) (describe (first (last *))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass final (bknr.datastore:store-object) ((city :accessor city :initarg :city) (year :accessor year :initarg :year :index-type bknr.indices:unique-index ;; added :index-reader final-by-year ;; added :index-values all-finals) ;; added (winner :accessor winner :initarg :winner)) (:metaclass bknr.datastore:persistent-class)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (final-by-year 1934) (length (all-finals)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require :acache) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass final () ((city :accessor city :initarg :city) (year :accessor year :initarg :year :index :any-unique) (winner :accessor winner :initarg :winner)) (:metaclass db.ac:persistent-class)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (db.ac:open-file-database "/tmp/db/" :if-does-not-exist :create :if-exists :supersede) db.ac:*allegrocache* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (loop for (city year winner) in '(("Rome" 1934 :ita) ("Paris" 1938 :ita) ("Bern" 1954 :deu) ("Stockholm" 1958 :bra)) for final = (make-instance 'final :city city :year year :winner winner) finally (return final)) ;; Oops, the same error again... (setf (city *) "Solna") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (db.ac:commit) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (db.ac:open-file-database "/tmp/db/") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (db.ac:retrieve-from-index 'final 'year 1958) (describe *) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC * Chapter-22 ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-22/hello.lisp][hello]] #+BEGIN_SRC lisp #-:abcl (defun hello () (format t "Hello World!~%The time is ~A.~%" (get-universal-time))) #+:abcl (defun hello (name) (format nil "Hello ~A!~%The time is ~A.~%" name (get-universal-time))) #+END_SRC ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-22/deliver.lisp][deliver]] #+BEGIN_SRC lisp (load (compile-file "code.lisp")) (lw:deliver nil "my_lib" 0 :dll-exports '("toLispTime")) #+END_SRC ** [[/Users/Can/Books/LISP Books/Common Lisp Recipes-code/chapter-22/code.lisp][code]] #+BEGIN_SRC lisp ;;; Copyright (c) 2015, Edmund Weitz. All rights reserved. ;;; This is example code for the book "Common Lisp Recipes" and meant ;;; to be used with something like (from SLIME) C-M-x or C-c C-c. ;;; See the book for more information. (eval-when (:compile-toplevel :load-toplevel :execute) (error "This code is not meant to be used with LOAD or COMPILE-FILE.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sb-posix:getenv "HOME") (sb-posix:setenv "WAKA" "Jawaka" 1) (sb-posix:getenv "WAKA") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ccl:getenv "HOME") (ccl:setenv "WAKA" "Jawaka") (ccl:getenv "WAKA") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ext:getenv "HOME") (setf (ext:getenv "WAKA") "Jawaka") (ext:getenv "WAKA") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (length (win32:collect-registry-subkeys "Hardware\\Description\\System\\CentralProcessor" :root :local-machine)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun test () (list (short-site-name) (long-site-name) (lisp-implementation-type) (lisp-implementation-version) (machine-instance) (machine-type) (machine-version) (software-type) (software-version))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun hello () (format t "Hello World!~%The time is ~A.~%" (get-universal-time))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sb-ext:save-lisp-and-die #p"foo.exe" :toplevel #'hello :executable t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ccl:save-application #p"foo.exe" :toplevel-function #'hello :prepend-kernel t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ext:saveinitmem #p"foo.exe" :init-function (lambda () (hello) (ext:quit)) :executable t :quiet t :norc t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (compile-file "/tmp/hello.lisp" :system-p t) (c:build-program #p"foo.exe" :lisp-files '(#p"/tmp/hello.o") :epilogue-code '(hello)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (sb-ext:save-lisp-and-die #p"/tmp/my-image") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (external-program:run "date" nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (external-program:run "date" nil :output *standard-output*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (external-program:run "date" '("-u") :output *standard-output*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-output-to-string (out) (external-program:run "date" '("-R") :output out)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-input-from-string (in (format nil "One~%Two~%Three~%")) (external-program:run "wc" '("-l") :output *standard-output* :input in)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see file "filter.c" in this directory (external-program:start "/tmp/foo" nil :input :stream :output :stream) (defparameter *p* *) (defparameter *in* (external-program:process-input-stream *p*)) (defparameter *out* (external-program:process-output-stream *p*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (format *in* "addressee~%") (finish-output *in*) (read-line *out*) (format *in* "committee~%") (format *in* "mississippi~%") (finish-output *in*) (list (read-line *out*) (read-line *out*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (external-program:process-status *p*) (close *in*) (external-program:process-status *p*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-open-stream (stream (sys:open-pipe "/tmp/foo" :direction :io)) (format stream "mississippi~%") (finish-output stream) (read-line stream)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see Lisp and C files in this directory (compile-file "/tmp/hello.lisp" :system-p t) (c:build-shared-library #p"/tmp/hello.so" :lisp-files '(#p"/tmp/hello.o") :init-name "init_mylib") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; see Lisp and C files in this directory (fli:define-foreign-callable ("toLispTime" :result-type :long) ((year :int) (month :int) (date :int)) (encode-universal-time 0 0 0 date month year)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun time-test () (let ((run-time (get-internal-run-time)) (real-time (get-internal-real-time))) (sleep 2.5) (format t "Run time: ~,6F seconds~%Real time: ~,6F seconds~%" (/ (- (get-internal-run-time) run-time) internal-time-units-per-second) (/ (- (get-internal-real-time) real-time) internal-time-units-per-second)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (time-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (get-decoded-time) (get-universal-time) (decode-universal-time *) (multiple-value-bind (second minute hour date month year day daylight-p zone) (decode-universal-time **) (declare (ignore day daylight-p zone)) (encode-universal-time second minute hour date month year)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (encode-universal-time 0 0 0 4 12 1993) (encode-universal-time 0 0 0 4 12 93) (encode-universal-time 0 0 0 21 12 1940) (encode-universal-time 0 0 0 21 12 40) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (nth-value 8 (get-decoded-time)) (nth-value 7 (get-decoded-time)) (encode-universal-time 0 10 17 24 8 2015) (encode-universal-time 0 10 17 24 8 2015 -2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (local-time:now) (local-time:encode-timestamp 123456789 0 10 12 23 12 1965) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (local-time:parse-timestring "1965-12-23") (local-time:parse-timestring "1965-12-23T12:20:12") (local-time:parse-timestring "1965-12-23T12:20:12-05") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (local-time:reread-timezone-repository) (local-time:timestamp-subtimezone (local-time:encode-timestamp 0 0 40 18 24 8 2015) (local-time:find-timezone-by-location-name "Europe/Moscow")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *timestamp* (local-time:encode-timestamp 0 13 5 19 24 8 2015)) (local-time:format-timestring nil *timestamp*) (local-time:format-timestring nil *timestamp* :format local-time:+rfc-1123-format+) (local-time:format-timestring nil *timestamp* :format '(:long-weekday ", " :day " " :long-month)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (local-time:enable-read-macros) @2015-08-24T19:05:13 (local-time:timestamp< @2015-08-24T19:05:13 @2015-07-14T20:00:33) (local-time:timestamp+ @2015-08-24T19:05:13 10 :day) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (room) (trivial-garbage:gc) (room) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *resources* (loop for i below 10 collect i)) *resources* (defclass foo () ((resource :initform (pop *resources*)))) (defparameter *objects* (loop repeat 5 collect (make-instance 'foo))) *resources* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (dolist (object *objects*) (trivial-garbage:finalize object (let ((resource (slot-value object 'resource))) (lambda () (push resource *resources*))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; continued from above (setq *objects* (cdr *objects*)) *resources* (trivial-garbage:gc :full t) *resources* (setq *objects* nil) (trivial-garbage:gc :full t) *resources* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+END_SRC