small-cl-src

small-cl-src@common-lisp.net

44 discussions

[Small-cl-src] Collection utility
by Thomas F. Burdick 03 Oct '04

03 Oct '04

#| In 2001, I spent a little too much time thinking about the optimal interface to a collection utility, as evidenced by this thread on comp.lang.lisp: http://groups.google.com/groups?threadm=xcvsnbgix4v.fsf%40famine.OCF.Berkel… I'd thought I posted the collection utility I wrote as a result, but I can't find it anywhere. So, three years later, here it is. |# ;;; Copyright 2001, 2002, Thomas F. Burdick ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (defpackage :org.no-carrier.collectors (:use :cl) (:export #:with-collectors #:collect)) (in-package #:org.no-carrier.collectors) (defmacro with-collectors ((&rest collectors) &body forms) "Evaluate FORMS with collectors established as specified by COLLECTORS. Each form in COLLECTORS can be a symbol, or a list of the form: (var &optional initial-value (fun name)) For each collector, a symbol-macro and a function are defined, allowing one to use the collector as either a variable or a function. The function takes one optional argument which is collected, if present. It returns the collected list so far. The initial value of the list being collected into will be INITIAL-VALUE. The list may be changed later by SETFing the collector. Care should be exercised, however, as this list will be modified." (loop for form in collectors for (head tail fun initvar initform) = (destructuring-bind (var &optional initform (fun var)) (if (listp form) form (list form)) (list var (gensym "TAIL-") fun (gensym "INIT-") initform)) collect `(,initvar ,initform) into inits collect `(,head ,initvar) into vars collect `(,tail (last ,initvar)) into vars collect head into var-names collect `(,fun (&optional (item nil itemp)) (when itemp (let ((new-cell (list item))) (if (consp ,tail) (setf (cdr ,tail) new-cell ,tail new-cell) (setf ,head new-cell ,tail new-cell)))) ,head) into funs collect fun into fun-names collect `((setf ,fun) (new-list &optional (item nil itemp)) (when itemp (,fun item)) (setf ,head new-list ,tail (last new-list)) ,head) into setfs collect `(setf ,fun) into setf-names collect `(,head (,fun)) into symbol-macros finally (return `(let ,inits (let ,vars (flet ,funs (declare (inline ,@fun-names)) (flet ,setfs (declare (inline ,@setf-names)) (symbol-macrolet ,symbol-macros (%with-more-collectors (,var-names ,fun-names) ,@forms))))))))) (define-symbol-macro %collector-alist nil) (defmacro collect (item &key into &environment env) "Collect ITEM into the collector INTO, which should be the collector's name as a variable." (let* ((alist (macroexpand-1 '%collector-alist env)) (fun (cdr (assoc into alist)))) (if fun `(,fun ,item) (error "Attempt to collect into unknown collector ~S." into)))) (defmacro %with-more-collectors ((vars funs) &body forms &environment env) (let ((alist (nconc (mapcar #'cons vars funs) (macroexpand-1 '%collector-alist env)))) `(symbol-macrolet ((%collector-alist ,alist)) ,@forms)))

1 0

[Small-cl-src] small mop compatability layer
by marco 01 Oct '04

01 Oct '04

;;;; -*- lisp -*- (defpackage :it.bese.arnesi.mopp (:nicknames :mopp) (:documentation "A MOP compatabilitly layer. This package wraps the various similar but slightly different MOP APIs. All the MOP symbols are exported (even those which are normally exported from the common-lisp package) though not all maybe be properly defined on all lisps. The name of library is a ancronym for "the Meta Object Protocol Package". Notes: The mopp package also exports the function SLOT-DEFINITION-DOCUMENTATION which while not strictly part of the MOP really should be and is implementened on most systems. Lispworks - (tested only lightly) Implement a eql-specializer class and define a version of method-specializers built upon clos:method-specializers which returns them. This package is part of the arnesi utility library but has been written so that this single file can be included in other applications without requiring the rest of the arnesi library.") (:use) (:export ;; classes #:standard-object #:funcallable-standard-object #:metaobject #:generic-function #:standard-generic-function #:method #:standard-method #:standard-accessor-method #:standard-reader-method #:standard-writer-method #:method-combination #:slot-definition #:direct-slot-definition #:effective-slot-definition #:standard-slot-definition #:standard-direct-slot-definition #:standard-effective-slot-definition #:specializer #:eql-specializer #:class #:built-in-class #:forward-referenced-class #:standard-class #:funcallable-standard-class ;; Taken from the MOP dictionary #:accessor-method-slot-definition #:add-dependent #:add-direct-method #:add-direct-subclass #:add-method #:allocate-instance #:class-default-initargs #:class-direct-default-initargs #:class-direct-slots #:class-direct-subclasses #:class-direct-superclasses #:class-finalized-p #:class-name #:class-precedence-list #:class-prototype #:class-slots #:compute-applicable-methods #:compute-applicable-methods-using-classes #:compute-class-precedence-list #:compute-default-initargs #:compute-discriminating-function #:compute-effective-method #:compute-effective-slot-definition #:compute-slots #:direct-slot-definition-class #:effective-slot-definition-class #:ensure-class-using-class #:ensure-generic-function #:ensure-generic-function-using-class #:eql-specializer-object #:extract-lambda-list #:extract-specializer-names #:finalize-inheritance #:find-method-combination #:funcallable-standard-instance-access #:generic-function-argument-precedence-order #:generic-function-declarations #:generic-function-lambda-list #:generic-function-method-class #:generic-function-method-combination #:generic-function-methods #:generic-function-name #:intern-eql-specializer #:make-instance #:make-method-lambda #:map-dependents #:method-function #:method-generic-function #:method-lambda-list #:method-specializers #:method-qualifiers #:reader-method-class #:remove-dependent #:remove-direct-method #:remove-direct-subclass #:remove-method #:set-funcallable-instance-function #:slot-boundp-using-class #:slot-definition-allocation #:slot-definition-documentation #:slot-definition-initargs #:slot-definition-initform #:slot-definition-initfunction #:slot-definition-location #:slot-definition-name #:slot-definition-readers #:slot-definition-writers #:slot-definition-type #:slot-makunbound-using-class #:slot-value-using-class #:specializer-direct-generic-functions #:specializer-direct-methods #:standard-instance-access #:update-dependent #:validate-superclass #:writer-method-class)) (defpackage :it.bese.arnesi.mopp%internals (:use :common-lisp)) (in-package :it.bese.arnesi.mopp%internals) (defgeneric provide-mopp-symbol (symbol implementation) (:documentation "Provide the implementation of the MOP symbol SYMBOL. SYMBOL - One of the external symbols of the package it.bese.arnesi.mopp IMPLEMENTATION - A keyword indetifying the implementation, one of: :OPENMCL, :SBCL, :CMU, :LISPWORKS. Do \"something\" such that the external symbol SYMBOL in the mopp package provides the sematics for the like named symbol in the MOP. Methods defined on this generic function are free to destructivly modify SYMBOL (and the mopp package) as long as when the method terminates there is a symbol with the same name as SYMBOL exported form the package mopp. Methods must return a true value if they have successfully provided SYMBOL and nil otherwise.")) (defun import-to-mopp (symbol) (let ((sym (find-symbol (string symbol) :it.bese.arnesi.mopp))) (when sym (unexport sym :it.bese.arnesi.mopp) (unintern sym :it.bese.arnesi.mopp))) (import symbol :it.bese.arnesi.mopp) (export symbol :it.bese.arnesi.mopp) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; OpenMCL (defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :openmcl))) "Provide MOP symbols for OpenMCL. All of OpenMCL's MOP is defined in the CCL package." (when (find-symbol (string symbol) :ccl) (import-to-mopp (find-symbol (string symbol) :ccl)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; SBCL (defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :sbcl))) (when (find-symbol (string symbol) :sb-pcl) (import-to-mopp (find-symbol (string symbol) :sb-pcl)))) (defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation)) (implementation (eql :sbcl))) "Provide SLOT-DEFINITION-DOCUMENTATION for SBCL. On SBCL SLOT-DEFINITION-DOCUMENTATION is just a call to sb-pcl:documentation." t) #+sbcl (defun mopp:slot-definition-documentation (slot) (sb-pcl::documentation slot t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; CMUCL (defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :cmu))) (when (find-symbol (string symbol) :pcl) (import-to-mopp (find-symbol (string symbol) :pcl)))) (defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation)) (implementation (eql :cmu))) "Provide SLOT-DEFINITION-DOCUMENTATION on CMUCL. Like SBCL SLOT-DEFINITION-DOCUMENTATION on CMUCL is just a call to documentation." t) #+cmu (defun mopp:slot-definition-documentation (slot) (documentation slot t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Lispworks (defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :lispworks))) (when (find-symbol (string symbol) :clos) (import-to-mopp (find-symbol (string symbol) :clos)))) (defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer)) (implementation (eql :lispworks))) t) (defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer-object)) (implementation (eql :lispworks))) t) (defmethod provide-mopp-symbol ((symbol (eql 'mopp:method-specializers)) (implementation (eql :lispworks))) "We can not simply export CLOS:METHOD-SPECIALIZERS as we have to insert mopp:eql-specializers" t) #+lispworks (defclass mopp:eql-specializer () ((object :accessor mopp::eql-specializer-object :initarg :object)) (:documentation "Wrapper class representing eql-specializers. Lispworks does not implement an eql-specializer class but simply returns lists form method-specializers, this class (along with a wrapper for clos:method-specializers) hides this detail.")) #+lispworks (defun mopp:method-specializers (method) "More MOP-y implementation of clos:method-specializers. For every returned value of clos:method-specializers of the form `(eql ,OBJECT) this function returns a mopp:eql-specializer object wrapping OBJECT." (mapcar (lambda (spec) (typecase spec (cons (make-instance 'mopp:eql-specializer :object (second spec))) (t spec))) (clos:method-specializers method))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Build the package ;; we can't jsut do a do-external-symbols since we mess with the ;; package and that would put us in implementation dependent ;; territory, so we first build up a list of all the external symbols ;; in mopp and then work on that list. (let ((external-symbols '())) (do-external-symbols (sym (find-package :it.bese.arnesi.mopp)) (push sym external-symbols)) (dolist (sym external-symbols) (unless (provide-mopp-symbol sym #+openmcl :openmcl #+sbcl :sbcl #+cmu :cmu #+lispworks :lispworks) (warn "Unimplemented MOP symbol: ~S" sym)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Copyright (C) 2004 Edward Marco Baringer <mb(a)bese.it> ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions are ;;;; met: ;;;; ;;;; - Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; ;;;; - Redistributions in binary form must reproduce the above copyright ;;;; notice, this list of conditions and the following disclaimer in the ;;;; documentation and/or other materials provided with the distribution. ;;;; ;;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;;;; of its contributors may be used to endorse or promote products ;;;; derived from this software without specific prior written permission. ;;;; ;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -Marco Ring the bells that still can ring. Forget your perfect offering. There is a crack in everything. That's how the light gets in. -Leonard Cohen

1 0

[Small-cl-src] with-carry
by Peter Lewerin 28 Sep '04

28 Sep '04

#| In a reply to me in c.l.l., Adam Warner suggested a control structure for the cases when a computation is made in stages, with the result of each stage used somewhere in the next stage. The following is basically his code; I added a SYMBOL-MACROLET wrapper to be able to name the carry-over variable. See c.l.l. thread "Which style do you prefer?" |# (defmacro with-carry (c stages &body body) (symbol-macrolet ((_ c)) `(let* (,@(loop for item in stages collect (list _ item))) ,@body))) ;; (with-carry x ((+ 2 3) (* x 10)) (print x)) ;; => 50 ;; expands to: (LET* ((X (+ 2 3)) (X (* X 10))) (PRINT X))

1 0

[Small-cl-src] with-static-types
by Peter Wilson 23 Sep '04

23 Sep '04

;;;; WITH-STATIC-TYPES macro ;;; A shorthand macro for specifying inline static types (the type x) without ;;; cluttering the code. As usual for static typing, avoid using it until ;;; fairly late in the optimization phase of your coding. ;;; ;;; This code has not been used anywhere besides the examples below and may ;;; still have undiscovered bugs. ;;; ;;; Be aware of name collisions between functions and variables. The macro ;;; currently only supports one namespace. ;;; ;;; TODO: Handle special forms in the body. Or at least LET. ;;; TODO: When handling LET, insert declarations for variables. ;;; TODO: Handle macros in the body. Probably just macroexpand them. ;;; TODO: Remove compile-time dependency on ITERATE package. ;;; (defpackage #:with-static-types (:use #:cl) (:export #:with-static-types)) (eval-when (:compile-toplevel :load-toplevel :execute) (in-package #:with-static-types) (require "iterate") (use-package '#:iterate)) (defun make-ring (x) "Create a circular list containing x." (let ((c (cons x nil))) (setf (cdr c) c))) (defun lookup-type (typed-functions sym) "Deduce the type of sym using the typed-functions alist. Returns: t value-or-return-type argument-types" (flet ((assert-length=2 (x) (unless (eq (cddr x) nil) (error "WITH-STATIC-TYPES: Not expecting more than one argument after ~S" (car x))))) (let ((found (assoc sym typed-functions))) (if found (destructuring-bind (found return-type . args) found (let ((arg-types (if args (case (car args) ((:argument-types :args) (assert-length=2 args) (cadr args)) ((:all-arguments-type :arg) (assert-length=2 args) (make-ring (cadr args))) (t (if (> (list-length args) 1) args (make-ring (car args))))) (make-ring return-type)))) (return-from lookup-type (values found return-type arg-types)))) nil)))) (defun apply-arg-types (typed-functions arg-types form) "Construct (the)'s for the arguments in form using the typespecs in arg-types." (flet ((recurse (form) (list 'with-static-types typed-functions form))) (list* (car form) (iter (for (arg . a-rest) on (cdr form)) (for (type . t-rest) on arg-types) (collect (list 'the type (recurse arg))) (when (and (null t-rest) (not (null a-rest))) (warn "WITH-STATIC-TYPES: More arguments than types for~& form: ~S~& types: ~S" form arg-types) (dolist (a a-rest) (collect (recurse a)))))))) (defun with-types-helper (typed-functions body) (flet ((recurse (form) (list 'with-static-types typed-functions form))) (iter (for form in body) (if (consp form) (multiple-value-bind (found return-type arg-types) (lookup-type typed-functions (car form)) (if found (collect (list 'the return-type (apply-arg-types typed-functions arg-types form))) ;TODO handle specials and macros here (collect (list* (car form) (mapcar #'recurse (cdr form)))))) (multiple-value-bind (found return-type) (lookup-type typed-functions form) (if found (collect (list 'the return-type form)) (collect form))))))) (defmacro with-static-types (function-typespecs &body body) "Insert type declarations around calls to specific functions. Also happens to work with variables. Usage: WITH-STATIC-TYPES ( spec ... ) body-form ... spec => ( sym result-and-arg-type ) | ( sym result-type all-arg-type ) | ( sym result-type arg-type-1 arg-type-2 ... ) | ( sym result-type :ALL-ARGUMENTS-TYPE all-arg-type ) | ( sym result-type :ARG all-arg-type ) | ( sym result-type :ARGUMENT-TYPES ( arg-type-1 arg-type-2 ... ) ) | ( sym result-type :ARGS ( arg-type-1 arg-type-2 ... ) ) Examples: (WITH-STATIC-TYPES ((+ FIXNUM)) (+ 1 2)) --> (PROGN (THE FIXNUM (+ (THE FIXNUM 1) (THE FIXNUM 2)))) ==> 3 (WITH-STATIC-TYPES ((+ FIXNUM) (/ RATIONAL FIXNUM)) (/ 3 (+ 2 2))) --> (PROGN (THE RATIONAL (/ (THE FIXNUM 3) (THE FIXNUM (THE FIXNUM (+ (THE FIXNUM 1) (THE FIXNUM 2))))))) ==> 3/4 (WITH-STATIC-TYPES ((+ FIXNUM) (/ RATIONAL FIXNUM FIXNUM)) (/ 3 (+ 2 2) 17)) WARNING: WITH-STATIC-TYPES: More arguments than types for form: (/ 3 (+ 2 2) 17) types: (FIXNUM FIXNUM) --> (PROGN (THE RATIONAL (/ (THE FIXNUM 3) (THE FIXNUM (THE FIXNUM (+ (THE FIXNUM 1) (THE FIXNUM 2)))) 17))) ==> 3/68 (WITH-STATIC-TYPES ((x FIXNUM)) x) --> (PROGN (THE FIXNUM x)) ==> Undefined variable x " (if body (list* 'progn (with-types-helper function-typespecs body)) (warn "WITH-STATIC-TYPES: Null body. types: ~S" function-typespecs)))

1 0

[Small-cl-src] tracing setf
by Pascal J.Bourguignon 10 Sep '04

10 Sep '04

;; TRACE cannot be applied on "built-ins", and in any case, not on a ;; special operator! So, here is a SETF* macro that will "trace" ;; the assignments. (defmacro setf* (&rest args) `(progn ,@(do ((var args (cddr var)) (body '())) ((null var) (nreverse body)) (push `(setf ,(car var) ,(cadr var)) body) (push `(format *trace-output* "~20:A := (THE ~S ~S) ~%" ',(car var) (type-of ,(car var)) ,(car var)) body))));;setf* ;; [144]> (decode-span-lex-word "*a\rguen~as#") ;; LINE := (THE (SIMPLE-BASE-STRING 9) "arguen~as") ;; (AREF NEW J) := (THE BASE-CHAR #\a) ;; J := (THE BIT 1) ;; I := (THE BIT 1) ;; (AREF NEW J) := (THE BASE-CHAR #\r) ;; J := (THE (INTEGER 0 16777215) 2) ;; I := (THE (INTEGER 0 16777215) 2) ;; (AREF NEW J) := (THE BASE-CHAR #\g) ;; J := (THE (INTEGER 0 16777215) 3) ;; I := (THE (INTEGER 0 16777215) 3) ;; (AREF NEW J) := (THE BASE-CHAR #\u) ;; J := (THE (INTEGER 0 16777215) 4) ;; I := (THE (INTEGER 0 16777215) 4) ;; (AREF NEW J) := (THE BASE-CHAR #\e) ;; J := (THE (INTEGER 0 16777215) 5) ;; I := (THE (INTEGER 0 16777215) 5) ;; (AREF NEW J) := (THE BASE-CHAR #\LATIN_SMALL_LETTER_N_WITH_TILDE) ;; J := (THE (INTEGER 0 16777215) 6) ;; I := (THE (INTEGER 0 16777215) 7) ;; (AREF NEW J) := (THE BASE-CHAR #\a) ;; J := (THE (INTEGER 0 16777215) 7) ;; I := (THE (INTEGER 0 16777215) 8) ;; (AREF NEW J) := (THE BASE-CHAR #\s) ;; J := (THE (INTEGER 0 16777215) 8) ;; I := (THE (INTEGER 0 16777215) 9) ;; LINE := (THE (SIMPLE-BASE-STRING 8) "argueñas") ;; "argueñas" ;; [145]> -- __Pascal Bourguignon__ http://www.informatimago.com/ Our enemies are innovative and resourceful, and so are we. They never stop thinking about new ways to harm our country and our people, and neither do we.

1 0

[Small-cl-src] Haven't you always wanted to clean sequences out?
by Ingvar 03 Sep '04

03 Sep '04

;;; Haven't we all felt the need to sanitize your sequences and making each ;;; element "unique"? I haven't, but I had some spare minutes waiting for ;;; a friend over lunch and since I'd been running the unix command uniq(1) ;;; and been irritated at its shortcomings, this came to be: (defun unique (data &key (test #'eql) (key #'identity)) (let ((acc nil) (type (typecase data (vector 'vector) (string 'string) (list 'list)))) (flet ((frob (data) (unless (member (funcall key data) acc :test test :key key) (push data acc)))) (map nil #'frob data)) (coerce (nreverse acc) type)))

2 1

[Small-cl-src] ipc.lisp
by Helmut Eller 28 Aug '04

28 Aug '04

;; ipc.lisp -- IPC with SYS V message queues. ;; ;; Written by Helmut Eller 2004 ;; ;; This package implements some Erlang-style concurrency primitives ;; with Unix processes and SYS V message queues. The following ;; primitives are available: ;; ;; spawn: forks a new process and calls a function in the new process. ;; ;; snd: sends a message to another process. The message must be ;; PRINTable and READable. ;; ;; rcv: receives a message. A test predicate can be used to ;; emulate `selective receive'. This operation blocks if there's no ;; message in the mailbox, but a timeout value can be specified. ;; ;; Some simple usage examples are at the end of this file. ;; ;; Caution: Erlangish link/unlink is not supported, so it is quite ;; difficult to handle errors in other processes. Currently a child ;; process prints a backtrace and exits instead of entering a ;; debugger. There's also no way to discover or kill other processes. ;; You'll have to use ps etc. for this. The SYS V message queues are ;; not reliably removed. Again you'll have to use ipcs and ipcrm to ;; do it manually. ;; ;; This code is written for CMUCL. (defpackage :ipc (:use :cl :ext :unix :alien :c-call) (:export :spawn :snd :rcv :self)) (in-package :ipc) (defvar *ipc-debug* t) (defun dbg (fstring &rest args) (when *ipc-debug* (apply #'format *debug-io* fstring args) (finish-output *debug-io*))) (defmacro ccall ((name rettype &rest argtypes) &rest args) "Call the C function NAME with ARGS." `(alien:alien-funcall (alien:extern-alien ,name (function ,rettype ,@argtypes)) ,@args)) (defmacro let-errno ((var errno value) &body body) "Execute VALUE; bind the result to VAR, bind ERRNO, and execute BODY." `(let ((,var ,value)) (let ((,errno ;; unix-errno is suddenly a function in recent cmucls. ,(cond ((fboundp 'unix:unix-errno) '(unix:unix-errno)) (t `(progn (unix::unix-get-errno) unix:unix-errno))))) ,@body))) (def-alien-type sap system-area-pointer) (def-alien-type uint unsigned) (defun unix-error (errno) (error "~A" (get-unix-error-msg errno))) (defconstant +ipc_nowait+ #x800) (defconstant +ipc_creat+ #x200) (defconstant +ipc_excl+ #x400) (defconstant +ipc_set+ #x1) (defconstant +ipc_rmid+ #x0) (defun %msgget (key flags) (ccall (msgget int uint uint) key flags)) (defun make-mq () "Create a new SYS V message queue. Return the (per process) queue handle and the public key." (let ((key (random #xffff))) (let-errno (mq errno (%msgget key (logior #o600 +ipc_creat+ +ipc_excl+))) (cond ((/= mq -1) (values mq key)) ((= errno unix:eexist) (make-mq)) ; retry with new key (t (unix-error errno)))))) (defun get-mq (key) "Get the (existing) message queue with id KEY." (let-errno (mq errno (%msgget key #o600)) (cond ((= mq -1) (unix-error errno)) (t mq)))) (defun delete-mq (mq) (dbg "; Closing: ~A (pid ~A)~%" mq (unix-getpid)) (let-errno (code errno (ccall (msgctl int int int sap) mq +ipc_rmid+ (sys:int-sap 0))) (cond ((zerop code)) (t (unix-error errno))))) (defun %msgsnd (mq string) (ccall (msgsnd int int sap uint uint) mq (sys:vector-sap string) (length string) +ipc_nowait+)) (defun msgsnd (mq string) "Write STRING to message queue MQ." (let-errno (code errno (%msgsnd mq string)) (cond ((/= code -1) nil) (t (unix-error errno))))) (defun %msgrcv (mq buffer) (ccall (msgrcv int int sap uint uint uint) mq (sys:vector-sap buffer) (length buffer) 0 0)) (defun msgrcv (mq) "Return the first message in MQ." (let ((buffer (make-string 8192))) (let-errno (code errno (%msgrcv mq buffer)) (cond ((/= code -1) (subseq buffer 0 code)) ((= errno unix:eintr) (msgrcv mq)) (t (unix-error errno)))))) (defun decode (string) (with-standard-io-syntax (read-from-string string))) (defun encode (message) (with-standard-io-syntax (prin1-to-string message))) ;;; Process structure (pendant to Erlangs PID) (defstruct (process (:conc-name process.) (:predicate process?)) ;; Unix PID (pid (required-argument) :type fixnum :read-only t) ;; The key of the SYSV message queue (qid (required-argument) :type fixnum :read-only t)) (defvar *queues* (make-hash-table) "Maps pids to SYSV IPC message queues.") (defun process-queue (process) (or (gethash (process.pid process) *queues*) (setf (process-queue process) (get-mq (process.qid process))))) (defun (setf process-queue) (queue process) (setf (gethash (process.pid process) *queues*) queue)) (defvar *self* nil) (defvar *parent* nil) (defvar *linked-processes* '()) (defvar *trap-exit* nil) (defun init-self () "Allocate a new message queue and initialize *SELF*." (multiple-value-bind (mq qid) (make-mq) (let ((p (make-process :pid (unix-getpid) :qid qid))) (setf (process-queue p) mq) (setf *self* p)))) (defun self () (or *self* (init-self))) (defun parent () *parent*) (defun self? (process) "Is PROCESS this unix process?" (equalp process (self))) (defun alive? (process) (unix-kill (process.pid process) :check)) (defvar *mailbox* (list)) (defun snd (message process) "Send MESSAGE to PROCESS." (cond ((self? process) (setf *mailbox* (nconc *mailbox* (list message)))) (t (msgsnd (process-queue process) (encode message))))) ;;; SYS V message queues have no support for receive with timeouts. ;;; We use the itimer to implement timeouts. (defun assert-timer-unused () "Raise an error if the reatime is already in use." (multiple-value-bind (ok isec iusec vsec vusec) (unix-getitimer :real) (declare (ignore ok isec iusec)) (assert (and (zerop vsec) (zerop vusec)) () "itimer already used"))) (defun decode-timeout (timeout) "Return the timevalue TIMEOUT as to two values integers SECS USECS. TIMEOUT the number of seconds." (multiple-value-bind (secs rem) (truncate timeout) (let ((usecs (round (* rem 1000000)))) (assert (or (plusp secs) (and (zerop secs) (plusp usecs)))) (values secs usecs)))) (defun with-timeout (timeout fn timeout-fn) "Call FN. If executing FN completes withing TIMEOUT seconds return the result. Otherwise abort, unwind the stack and call TIMEOUT-FN instead. TIMEOUT is in seconds (can be a float). Return either the result of executing FN or the result of calling TIMEOUT-FN." (if (minusp timeout) (funcall timeout-fn) (%with-timeout timeout fn timeout-fn))) (defun %with-timeout (timeout fn timeout-fn) (block abort (return-from %with-timeout (labels ((handler (signal code scp) (declare (ignore signal code scp)) (return-from abort nil))) (multiple-value-bind (secs usecs) (decode-timeout timeout) (assert-timer-unused) (sys:with-enabled-interrupts ((unix:sigalrm #'handler)) (unix-setitimer :real 0 0 secs usecs) (unwind-protect (funcall fn) (unix-setitimer :real 0 0 0 0))))))) (funcall timeout-fn)) (defun endtime (timeout) (+ (get-internal-real-time) (/ timeout (coerce internal-time-units-per-second 'double-float)))) (defun seconds-until (endtime) (* (- endtime (get-internal-real-time)) internal-time-units-per-second)) (defun rcv-from-mq (mq test endtime) "Return the first message from MQ satisfying the predicate TEST. The second return value is non-nil when timeout ENDTIME expires." (let ((msg (if endtime (with-timeout (seconds-until endtime) (lambda () (decode (msgrcv mq))) (lambda () (return-from rcv-from-mq (values nil t)))) (decode (msgrcv mq))))) (cond ((funcall test msg) (values msg nil)) (t (setf *mailbox* (nconc *mailbox* (list msg))) (rcv-from-mq mq test endtime))))) (defun rcv (&key (test (constantly t)) timeout) "Receive the next message which satisfies TEST. Return the message and a flag indicating whether the timeout expired." (let ((tail (member-if test *mailbox*))) (cond (tail (setf *mailbox* (nconc (ldiff *mailbox* tail) (cdr tail))) (values (car tail) nil)) (t (rcv-from-mq (process-queue (self)) test (if timeout (endtime timeout))))))) (in-package :vm) (eval-when (:compile-toplevel :load-toplevel :execute) (defknown %reset-csp (function) nil) ;; Reset the control stack and call FN with the empty stack. ;; Unwind-protect blocks are reset and NOT executed. (define-vop (reset-csp) (:policy :fast-safe) (:args (fn :scs (descriptor-reg control-stack))) (:save-p t) (:translate %reset-csp) (:generator 0 (move eax-tn fn) (load-foreign-data-symbol esp-tn "control_stack_end") (inst mov esp-tn (make-ea :dword :base esp-tn)) (store-symbol-value 0 lisp::*current-catch-block*) (store-symbol-value 0 lisp::*current-unwind-protect-block*) (inst push 0) (inst mov ebp-tn esp-tn) (inst mov esi-tn esp-tn) (inst jmp (make-fixup 'tail-call-variable :assembly-routine))))) (in-package :ipc) (defun call-with-empty-stacks (fn) (mp::unbind-binding-stack) (setf x86::*alien-stack* (kernel:make-lisp-obj mp::*alien-stack-top*)) (setf kernel:*eval-stack-top* 0) (setf (kernel:binding-stack-pointer-sap) (alien:extern-alien "binding_stack" system-area-pointer)) (vm::%reset-csp fn)) (defun child-debugger-hook (condition hook) "Print a backtrace and exit." (declare (ignore hook)) (ignore-errors (format *debug-io* "~2&~A~% [Condition of type ~S]~2&" (debug::safe-condition-message condition) (type-of condition))) (ignore-errors (debug:backtrace)) (throw '%exit-child nil)) (defun start-child (stream mq fn args) (let ((*standard-output* stream) (*debug-io* stream) (*error-output* stream) (*query-io* stream) (*standard-input* stream)) (catch '%exit-child (unwind-protect (let ((*debugger-hook* (lambda (c h) (child-debugger-hook c h)))) (apply fn args)) (ignore-errors (delete-mq mq) (dbg "; Child exited: ~S~%" (self)) (lisp::finish-standard-output-streams)) (unix:unix-exit))))) (defun initialize-child (parent mq qid) (setf *parent* parent) (setf *self* (make-process :pid (unix-getpid) :qid qid)) (setf (process-queue *self*) mq) (setf *mailbox* (list))) (defun %spawn (fn args) (multiple-value-bind (mq qid) (make-mq) (let ((parent (self))) (mapc #'force-output (list *standard-output* *debug-io* *query-io*)) ;; CMUCL's SIGCHLD handler (sys:enable-interrupt unix:sigchld #'ext::sigchld-handler) (multiple-value-bind (pid errno) (unix-fork) (cond ((and pid (zerop pid)) (initialize-child parent mq qid) (let ((io *debug-io*)) (call-with-empty-stacks (lambda () (start-child io mq fn args))))) (pid (dbg "; Forked: ~D ~D (parent ~D)~%" pid qid (unix-getpid)) (let ((child (make-process :pid pid :qid qid))) (setf (process-queue child) mq) child)) (t (error "fork: ~A" (get-unix-error-msg errno)))))))) (defun spawn (fn &rest args) "Create a new process and apply FN to ARGS in the new process." (%spawn fn args)) #| ;; The counter process maintains the current value. Operations on the ;; counter are invoked via messges. The messages are as follows: ;; :up incerments the counter ;; :quit termintates the counter process ;; <a process> sends the current value to the process. (defun counter (value) (dbg "value: ~S~%" value) (let ((msg (rcv))) (dbg "msg: ~S~%" msg) (cond ((eq msg :up) (counter (1+ value))) ((eq msg :down) (counter (1- value))) ((eq msg :quit) ;; return ) ((process? msg) (snd value msg) (counter value))))) (defun test-counter () (let ((p (spawn (lambda () (counter 0))))) (snd :up p) (snd (self) p) (format t "~&value: ~A~&" (rcv)) (snd :up p) (snd (self) p) (format t "~&value: ~A~&" (rcv)) (snd :quit p))) ;; This expamle counts the nodes in a cons tree by spawing a new ;; process for each subtree. (defun count-nodes-aux (tree parent) "Count the number of nodes in TREE an send it to PARENT." (cond ((atom tree) (snd 1 parent)) (t (spawn #'count-nodes-aux (car tree) (self)) (spawn #'count-nodes-aux (cdr tree) (self)) (snd (+ 1 (rcv) (rcv)) parent)))) (defun count-nodes (tree) (count-nodes-aux tree (self)) (rcv)) (defun test-count-nodes () (time (count-nodes '(a ((b c)) d e )))) |# ;; Local Variables: ;; eval: (put 'let-errno 'common-lisp-indent-function 1) ;; End:

1 0

[Small-cl-src] bit I/O
by Zach Beane 27 Aug '04

27 Aug '04

;;;; The following stuff is taken, verbatim and somewhat unpolished, ;;;; from something I'm currently working on. ;;;; ;;;; Bit-level I/O. The Flash spec has various structures packed into ;;;; bit fields. ;;;; ;;;; $Id: bitio.lisp,v 1.5 2004/07/08 02:47:20 xach Exp $ (in-package :flash) (defclass bitstream () ((current-byte :initarg :current-byte :accessor current-byte) (bits-left :initarg :bits-left :accessor bits-left) (stream :initarg :stream :reader stream)) (:documentation "A class for writing or reading bits to or from an (UNSIGNED-BYTE 8) stream.")) ;;; Input (defun make-input-bitstream (stream &key (current-byte 0) (bits-left 0)) "Return a bitstream suitable for reading. The CURRENT-BYTE and BITS-LEFT, if specified, initialize the internal byte buffer and count." (assert (input-stream-p stream)) (assert (subtypep (stream-element-type stream) '(unsigned-byte 8))) (make-instance 'bitstream :stream stream :current-byte current-byte :bits-left bits-left)) (defmethod read-bits (width (bitstream bitstream) &optional (signedp nil)) (with-accessors ((bits-left bits-left) (input stream) (current-byte current-byte)) bitstream (loop with result = 0 with bits-needed = width while (plusp bits-needed) if (> bits-needed bits-left) do (setf result (logior (ash result bits-left) (ldb (byte bits-left 0) current-byte)) bits-needed (- bits-needed bits-left) current-byte (read-byte input) bits-left 8) else do (setf result (logior (ash result bits-needed) (ldb (byte bits-needed (- bits-left bits-needed)) current-byte)) bits-left (- bits-left bits-needed) bits-needed 0) finally (if (and signedp (logbitp (1- width) result)) (return (1- (- (logandc2 (1- (ash 1 width)) result)))) (return result))))) (defmethod read-boolean ((bitstream bitstream)) "Read and return a single bit from BITSTREAM as a boolean." (logbitp 0 (read-bits 1 bitstream))) (defmacro with-input-bitstream ((bitstream stream &key (current-byte 0) (bits-left 0)) &body body) "Evaluate BODY with a newly-created input bitstream bound to BITSTREAM." (let ((-current-byte- (gensym)) (-bits-left- (gensym))) `(let* ((,-current-byte- ,current-byte) (,-bits-left- ,bits-left) (,bitstream (make-input-bitstream ,stream :current-byte ,-current-byte- :bits-left ,-bits-left-))) ,@body))) ;;; Output (defun make-output-bitstream (stream &key (current-byte 0) (bits-left 8)) "Return a bitstream suitable for writing. The CURRENT-BYTE and BITS-LEFT, if specified, initialize the internal byte buffer and count." (assert (output-stream-p stream)) (assert (subtypep (stream-element-type stream) '(unsigned-byte 8))) (make-instance 'bitstream :stream stream :current-byte current-byte :bits-left bits-left)) (defmethod write-bits (integer width (bitstream bitstream)) "Write the rightmost WIDTH bits from INTEGER to the bitstream" (with-accessors ((bits-left bits-left) (stream stream) (current-byte current-byte)) bitstream (when (minusp integer) (setf integer (ldb (byte width 0) integer))) (loop with bits-needed = width while (plusp bits-needed) if (> bits-needed bits-left) do (setf (ldb (byte bits-left 0) current-byte) (ldb (byte bits-left (- bits-needed bits-left)) integer) bits-needed (- bits-needed bits-left)) (write-byte current-byte stream) (setf current-byte 0 bits-left 8) else do (setf (ldb (byte bits-needed (- bits-left bits-needed)) current-byte) (ldb (byte bits-needed 0) integer) bits-left (- bits-left bits-needed) bits-needed 0)))) (defmethod write-bit (bit (bitstream bitstream)) "Write a single bit to the bitstream." (write-bits bit 1 bitstream)) (defmethod write-boolean (boolean (bitstream bitstream)) "Write BOOLEAN as a bit to the bitstream." (if boolean (write-bit 1 bitstream) (write-bit 0 bitstream))) (defmethod finish-write ((bitstream bitstream)) "Flush the output buffer byte of BITSTREAM. Uninitialized bits are written as 0." (when (< (bits-left bitstream) 8) (write-byte (current-byte bitstream) (stream bitstream)) (setf (current-byte bitstream) 0) (setf (bits-left bitstream) 8))) (defmacro with-output-bitstream ((bitstream stream &key (current-byte 0) (bits-left 8)) &body body) "Evaluate BODY with a newly-created output bitstream bound to BITSTREAM. Pending output is flushed at the end of evaluation." (let ((-current-byte- (gensym)) (-bits-left- (gensym))) `(let* ((,-current-byte- ,current-byte) (,-bits-left- ,bits-left) (,bitstream (make-output-bitstream ,stream :current-byte ,-current-byte- :bits-left ,-bits-left-))) (unwind-protect (progn ,@body) (finish-write ,bitstream))))) (defun test-bitstreams (file width integer) (with-open-file (output file :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede :if-does-not-exist :create) (with-output-bitstream (bitstream output) (write-bits integer width bitstream))) (with-open-file (input file :direction :input :element-type '(unsigned-byte 8)) (with-input-bitstream (bitstream input) (list (read-bits width bitstream t) integer)))) ;;; Utility (defun sufficient-bits (&rest numbers) "Return the number of bits necessary to represent the largest number in NUMBERS." (loop for number in numbers maximizing (1+ (integer-length number))))

1 1

[Small-cl-src] WITH*
by Marco Baringer 16 Jul '04

16 Jul '04

;;;; Alleviate deep nesting. Suggestions for a better name are welcome. ;;;; ;;;; An example will explain this far better than i can with words, so: ;;;; ;;;; (with* ;;;; (let ((*special* '())) (declare (special *special*))) ;;;; (dolist (a a-list)) ;;;; (with-slots (foo bar baz) a) ;;;; (multiple-value-bind (c d e) (process baz)) ;;;; (progn ;;;; body)) ;;;; ==> ;;;; (let ((*special* '())) ;;;; (declare (special *special*)) ;;;; (dolist (a a-list) ;;;; (with-slots (foo bar baz) ;;;; a ;;;; (multiple-value-bind (c d e) ;;;; (process baz) ;;;; body)))) (defmacro with* (&body body) (cond ((cddr body) (append (first body) `((with* ,@(cdr body))))) ((cdr body) `(,@(first body) ,(second body))) (body (first body)) (t nil))) -- -Marco Ring the bells that still can ring. Forget your perfect offering. There is a crack in everything. That's how the light gets in. -Leonard Cohen

1 0

[Small-cl-src] packet.lisp, version 2
by Luke Gorrie 12 Jul '04

12 Jul '04

;;; packet.lisp -- Decode TCP/IP packets (version 2) ;;; Written by Luke Gorrie <luke(a)bluetail.com> in May of 2004. ;;; ;;; A PDF version of this source file can be found at: ;;; http://www.bluetail.com/~luke/misc/lisp/packet.pdf ;;; ;;; Revision history: ;;; ;;; Version 2: Added support for encoding. ;;; Dropped alist support. Now always using structures. ;;; ;;; TODO: conditions, IPv4 options, TCP. ;;; ;;;# Introduction ;;; ;;; This is a program for encoding and decoding the packet headers of ;;; some TCP/IP family protocols. It converts between packets ;;; represented as octet-vectors and structures. ;;; ;;; This program is a library; it's not very useful in itself. ;;; ;;; Written for CMUCL 19A. I've used some non-portable features: ;;; `ext:collect', `slot-value' on structures, and PCL introspection. ;; Avoid calling defpackage is the package already exists. ;; Is this correct? It does avoid a lot of irritating warnings due to ;; the programmed exports at the end of the file. (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "PACKET") (defpackage :packet (:use :common-lisp) ;; Note: structures and their accessors are auto-exported down below. (:export #:decode #:encode #:buffer #:octet #:packet #:header)))) (in-package :packet) ;;;# Top-level interface ;;; ;;; The program has two main data types: buffers and packets. Buffers ;;; are octet-vectors for the encoded binary representations of ;;; packets. ;;; (deftype buffer () "A network packet represented as a vector of octets." '(array octet (*))) (deftype octet () "An unsigned 8-bit byte." '(unsigned-byte 8)) ;;; A packet is a list of header structures followed by zero or more ;;; buffers of raw data. This is the representation of a decoded ;;; network packet's headers and payload. Note that the individual ;;; header types are defined down below in the protocol-specific ;;; sections. ;;; (deftype packet () "A list of headers and buffers representing a network packet." 'cons) (deftype header () "A decoded protocol header." '(or ethernet-header arp-header ipv4-header udp-header)) ;;; The `decode' and `encode' functions convert between the buffer and ;;; packet representations. They are inverse operations when applied ;;; to well-formed inputs. ;;; (declaim (ftype (function (buffer) packet) decode) (ftype (function (packet) buffer) encode)) (defun decode (buffer) "Decode BUFFER as a packet." (decode-headers buffer)) (defun encode (packet) "Encode PACKET into a buffer." (encode-headers packet)) ;;;# I/O machinery ;;; ;;; All our I/O is based on treating a `buffer' (octet-vector) as a ;;; stream of bits. For decoding we "grab" quantities of bits from the ;;; buffer as needed, and for encoding we similarly "shove" bits into ;;; an output buffer. ;;;## Input "grabbing" (defvar *decode-buffer* nil "Buffer containing the packet currently being decoded.") (defvar *decode-position* nil "Current bit-position in *DECODE-BUFFER*.") (defmacro with-buffer-input (buffer &body body) "Execute BODY, grabbing input from the beginning of BUFFER." `(let ((*decode-buffer* ,buffer) (*decode-position* 0)) ,@body)) (defun bit-octet (bit &optional (check-alignment t)) "Convert from bit position to octet position." (multiple-value-bind (quotient remainder) (truncate bit 8) (when (and check-alignment (plusp remainder)) (error "Bit-position ~S is not octet-aligned." bit)) quotient)) (defun octet-bit (octet) "Convert from octet position to bit position." (* 8 octet)) ;;; "Grab" functions consume input from `*decode-buffer*' and advance ;;; `*decode-position*'. (defun grab-octets (num) "Grab a vector of NUM octets." (let ((start (bit-octet *decode-position*))) (incf *decode-position* (* num 8)) (subseq *decode-buffer* start (+ num start)))) (defun grab-ethernet-address () (make-ethernet-address :octets (grab-octets 6))) (defun grab-ipv4-address () (make-ipv4-address :octets (grab-octets 4))) (defun grab-rest () "Grab the rest of the buffer into an octet vector." (prog1 (subseq *decode-buffer* (bit-octet *decode-position*)) (setf *decode-position* (octet-bit (length *decode-buffer*))))) (defmacro dpb! (value bytespec place) "Deposit VALUE into BYTESPEC of PLACE." `(setf ,place (dpb ,value ,bytespec ,place))) ;;; I've written this function countless times but it always comes out ;;; ugly. What's the right way? (defun grab-bits (bits) "Grab a BITS-long unsigned integer" (let ((accumulator 0) (remaining bits)) (flet ((accumulate-byte () ;; Accumulate the relevant part of the current byte and ;; advance to the next one. (let* ((size (min remaining (- 8 (rem *decode-position* 8)))) (offset (rem (- 8 (rem (+ *decode-position* size) 8)) 8)) (value (ldb (byte size offset) (aref *decode-buffer* (bit-octet *decode-position* nil))))) (decf remaining size) (dpb! value (byte size remaining) accumulator) (incf *decode-position* size)))) (loop while (plusp remaining) do (accumulate-byte)) accumulator))) (defun grab-bitflag () "Grab a single bit. Return T if it's 1 and NIL if it's 0." (= (grab-bits 1) 1)) ;;;## Output "shoving" (defvar *encode-buffer* nil "Buffer (adjustable and with fill-pointer) for encoding data into.") (defvar *encode-position* nil "The encoding position in *ENCODE-BUFFER*.") (defvar *encode-bit-bucket* 0 "Accumulator for smaller-than-byte output.") (defvar *encode-bit-offset* 0 "The current accumulator bit-position.") (defmacro with-buffer-output (() &body body) `(let ((*encode-buffer* (make-array '(0) :element-type 'octet :adjustable t :fill-pointer 0)) (*encode-position* 0) (*encode-bit-bucket* 0) (*encode-bit-offset* 0)) ,@body (coerce *encode-buffer* 'buffer))) (defun encoding-position () (length *encode-buffer*)) (defmacro with-buffer-patch (position &body body) "Shove output at POSITION, overwriting any that was already there. Used within WITH-BUFFER-OUTPUT." `(let ((*encode-position* ,position)) ,@body)) ;;; "Shove" functions extend `*encode-buffer*' and advance ;;; `*encode-position*'. (defun shove-octet (octet) (unless (zerop *encode-bit-offset*) (error "Attempt to shove an octet at unaligned position.")) (cond ((= *encode-position* (length *encode-buffer*)) (vector-push-extend octet *encode-buffer*) (incf *encode-position*)) ((< *encode-position* (length *encode-buffer*)) (setf (aref *encode-buffer* *encode-position*) octet) (incf *encode-position*)) (t (error "Can't shove to position ~D with ~D-length buffer!" *encode-position* (length *encode-buffer*))))) (defun shove-ethernet-address (address) (shove-vector (ethernet-address.octets address))) (defun shove-ipv4-address (address) (shove-vector (ipv4-address.octets address))) (defun shove-vector (vector) (map nil #'shove-octet vector)) (defun shove-bits (value nbits) "Shove NBITS of VALUE." (cond ((zerop nbits)) ((< (+ *encode-bit-offset* nbits) 8) ;; We can fit NBITS into the accumulator without filling it. ;; Deposit VALUE into the most-significant accumulator bits ;; available. (let ((store-offset (- 8 nbits *encode-bit-offset*))) (dpb! value (byte nbits store-offset) *encode-bit-bucket*) (incf *encode-bit-offset* nbits))) (t ;; We have at least enough data to complete a byte. We ;; consume enough of VALUE's most-significant bits to fill ;; the accumulator, output a byte, then recurse on any ;; remainder. (let* ((take-bits (- 8 *encode-bit-offset*)) ;; The TAKE-BITS most-significant bits of VALUE. (take-value (ldb (byte take-bits (- nbits take-bits)) value)) (store-offset (- 8 take-bits *encode-bit-offset*)) (remaining (- nbits take-bits))) (dpb! take-value (byte take-bits store-offset) *encode-bit-bucket*) (setf *encode-bit-offset* 0) (shove-octet *encode-bit-bucket*) ;; Recurse with the remainder. (shove-bits value remaining))))) ;;;# Protocol implementations ;;; ;;; Each protocol defines a pair of GRAB and SHOVE functions for its ;;; headers. (defvar *resolve-protocols* t "When non-nil protocol numbers are resolved to symbolic names. Unrecognised numbers are left as numbers.") (defun lookup (key alist &key (errorp t) (reversep nil)) "Lookup the value of KEY in ALIST. If the key is not present and ERRORP is true then an error is signalled; if ERRORP is nil then the key itself is returned." (let ((entry (funcall (if reversep #'rassoc #'assoc) key alist))) (cond (entry (funcall (if reversep #'car #'cdr) entry)) (errorp (error "Key ~S is not present in ~A." key alist)) (t key)))) (defun rlookup (key alist) "Lookup the value of KEY in CDR-position in ALIST, else return KEY." (lookup key alist :errorp nil :reversep t)) ;;;## Ethernet ;;;### ethernet-address ;;; ;;; This big `eval-when' is needed to define the read-syntax for ;;; `ethernet-address' such that it can be used in this file. ;;; ;;; The read syntax is `#e"ff:00:1:2:3:4'. ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (ethernet-address (:conc-name #:ethernet-address.) (:print-function print-ethernet-address)) "48-bit Ethernet MAC address." (octets (ext:required-argument) :type (array octet (6)))) (defun read-ethernet-address (stream &optional c n) "Read an ethernet address in colon-separated syntax. Example: #e\"1:2:3:4:5:6\"" (declare (ignore c n)) (let ((value-stream (make-string-input-stream (read stream t nil t))) (*readtable* (copy-readtable)) (*read-base* 16)) (set-syntax-from-char #\: #\Space) (let ((vec (make-array '(6) :element-type 'octet))) (dotimes (i 6) (let ((octet (read value-stream t nil t))) (unless *read-suppress* (setf (elt vec i) octet)))) (unless *read-suppress* (make-ethernet-address :octets vec))))) (set-dispatch-macro-character #\# #\e 'read-ethernet-address) (defun print-ethernet-address (address stream depth) "Print ethernet addresses as in #e\"0:ff:1:2:3:4\"." (declare (ignore depth)) (format stream "#e\"~{~16,2,'0R~^:~}\"" (coerce (ethernet-address.octets address) 'list))) (defmethod make-load-form ((s ethernet-address) &optional env) (make-load-form-saving-slots s :environment env))) ;;;### Decode and encode (defstruct (ethernet-header (:conc-name #:ethernet-header.)) (dest nil :type (or null ethernet-address)) (source nil :type (or null ethernet-address)) (protocol nil :type (or null (unsigned-byte 16) symbol))) (defparameter *ethernet-protocol-names* '((#x0806 . :arp) (#x0800 . :ipv4)) "Mapping from ethernet protocol numbers to symbolic names.") (defun grab-ethernet-header () "Grab an ethernet header and call FUNCTION with each part." (let ((struct (make-ethernet-header))) (flet ((header (name value) (setf (slot-value struct name) value))) (header 'dest (grab-ethernet-address)) (header 'source (grab-ethernet-address)) (header 'protocol (ethernet-protocol-name (grab-bits 16)))) struct)) (defun ethernet-protocol-name (number) "Return the symbolic protocol name of NUMBER, if appropriate." (if *resolve-protocols* (lookup number *ethernet-protocol-names* :errorp nil) number)) (defun shove-ethernet-header (header) (declare (type ethernet-header header)) (with-slots (dest source protocol) header (shove-ethernet-address dest) (shove-ethernet-address source) (shove-bits (rlookup protocol *ethernet-protocol-names*) 16)) (constantly nil)) ;;;## ARP (defstruct (arp-header (:conc-name #:arp-header.)) (hardware-type nil :type (or null (unsigned-byte 16))) (protocol-type nil :type (or null (unsigned-byte 16))) (hardware-length nil :type (or null (unsigned-byte 8))) (protocol-length nil :type (or null (unsigned-byte 8))) (operation nil :type (or null symbol (unsigned-byte 16))) (sender-ha nil :type (or null ethernet-address)) (sender-ip nil :type (or null ipv4-address)) (target-ha nil :type (or null ethernet-address)) (target-ip nil :type (or null ipv4-address))) (defun grab-arp-header () "Grab an ARP header and call FUNCTION with each part." (let ((struct (make-arp-header))) (flet ((header (name value) (setf (slot-value struct name) value))) (header 'hardware-type (grab-bits 16)) (header 'protocol-type (grab-bits 16)) (header 'hardware-length (grab-bits 8)) (header 'protocol-length (grab-bits 8)) (header 'operation (arp-operation (grab-bits 16))) (header 'sender-ha (grab-ethernet-address)) (header 'sender-ip (grab-ipv4-address)) (header 'target-ha (grab-ethernet-address)) (header 'target-ip (grab-ipv4-address))) struct)) (defvar *arp-operation-names* '((1 . :request) (2 . :response)) "Mapping between ARP operation numbers and their symbolic names.") (defun arp-operation (operation) "Return the symbolic name for OPERATION, if appropriate." (if *resolve-protocols* (lookup operation *arp-operation-names* :errorp nil) operation)) (defun shove-arp-header (header) (declare (type arp-header header)) (with-slots (hardware-type protocol-type hardware-length protocol-length operation sender-ha sender-ip target-ha target-ip) header (shove-bits hardware-type 16) (shove-bits protocol-type 16) (shove-octet hardware-length) (shove-octet protocol-length) (shove-bits (rlookup operation *arp-operation-names*) 16) (shove-ethernet-address sender-ha) (shove-ipv4-address sender-ip) (shove-ethernet-address target-ha) (shove-ipv4-address target-ip)) (constantly nil)) ;;;## IPv4 ;;; ;;; The Internet Protocol is described in RFC791. ;;; ;;;### ipv4-address ;;; ;;; IP addresses also have a special read-syntax: `(a)10.0.0.1'. ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (ipv4-address (:conc-name #:ipv4-address.) (:print-function print-ipv4-address)) (octets (ext:required-argument) :type (array octet (4)))) (defun read-ipv4-address (stream &optional c n) "Read an IPv4 address in dotted-quad format. Example: @192.168.0.1" (declare (ignore c n)) (let ((*readtable* (copy-readtable))) (set-syntax-from-char #\. #\Space) (let ((vec (make-array '(4) :element-type 'octet))) (dotimes (i 4) (let ((octet (read stream t nil t))) (unless *read-suppress* (setf (elt vec i) octet)))) (unless *read-suppress* (make-ipv4-address :octets vec))))) (set-macro-character #\@ 'read-ipv4-address t) (defun print-ipv4-address (address stream depth) "Print IPv4 addresses as in @192.168.0.1." (declare (ignore depth)) (format stream "@~{~A~^.~}" (coerce (ipv4-address.octets address) 'list))) (defmethod make-load-form ((s ipv4-address) &optional env) (make-load-form-saving-slots s :environment env))) ;;;### decoder (defstruct (ipv4-header (:conc-name #:ipv4-header.)) (version nil :type (or null (unsigned-byte 4))) (hlen nil :type (or null (unsigned-byte 4))) (tos nil :type (or null (unsigned-byte 8))) (total-len nil :type (or null (unsigned-byte 16))) (id nil :type (or null (unsigned-byte 16))) (flags nil :type (or null (unsigned-byte 3))) (fragment-offset nil :type (or null (unsigned-byte 13))) (ttl nil :type (or null (unsigned-byte 8))) (protocol nil :type (or null symbol (unsigned-byte 8))) (checksum nil :type (or null (unsigned-byte 16))) (source nil :type (or null ipv4-address)) (dest nil :type (or null ipv4-address))) (defconstant ipv4-min-hlen 5 "The header length (in 32-bit words) of an IPv4 packet with no options.") (defun grab-ipv4-header () (let ((struct (make-ipv4-header)) (header-start-pos (bit-octet *decode-position*)) hlen checksum) (flet ((header (name value) (setf (slot-value struct name) value))) (header 'version (grab-bits 4)) (header 'hlen (setf hlen (grab-bits 4))) (header 'tos (grab-bits 8)) (header 'total-len (grab-bits 16)) (header 'id (grab-bits 16)) (header 'flags (grab-bits 3)) (header 'fragment-offset (grab-bits 13)) (header 'ttl (grab-bits 8)) (header 'protocol (if *resolve-protocols* (ipv4-protocol (grab-bits 8)) (grab-bits 8))) (header 'checksum (setf checksum (grab-bits 16))) (header 'source (grab-ipv4-address)) (header 'dest (grab-ipv4-address)) ;; FIXME (unless (= hlen ipv4-min-hlen) (error "Can't decode options in IPv4 packets.")) (let* ((initial (- checksum)) (header-octets (* hlen 4)) (computed-checksum (checksum *decode-buffer* :position header-start-pos :length header-octets :initial initial))) (unless (eql checksum computed-checksum) (error "Bad checksum: Got ~D, computed ~D." checksum computed-checksum)))) struct)) (defvar ipv4-protocol-names '((1 . :icmp) (6 . :tcp) (17 . :udp)) "Mapping between IPv4 protocol numbers and their symbolic names.") (defun ipv4-protocol (number) "Return the symbolic name for protocol NUMBER, if appropriate." (if *resolve-protocols* (lookup number ipv4-protocol-names :errorp nil) number)) (defconstant ipv4-no-options-hlen 5) (defun shove-ipv4-header (header) "Shove an IPv4 header. The length and checksum fields are computed automatically." (with-slots (version hlen tos total-len id flags fragment-offset ttl protocol checksum source dest) header (let (start total-len-pos checksum-pos) (setf start (encoding-position)) (shove-bits version 4) (shove-bits ipv4-no-options-hlen 4) (shove-bits tos 8) (setf total-len-pos (encoding-position)) (shove-bits 0 16) ; total-len (shove-bits id 16) (shove-bits flags 3) (shove-bits fragment-offset 13) (shove-bits ttl 8) (shove-bits (rlookup protocol ipv4-protocol-names) 8) ;; Remember where the checksum is: we have to come back and ;; patch it in. (setf checksum-pos (encoding-position)) (shove-bits 0 16) (shove-ipv4-address source) (shove-ipv4-address dest) (lambda () (with-buffer-patch total-len-pos (let ((total-len (- (length *encode-buffer*) start))) (shove-bits total-len 16))) (with-buffer-patch checksum-pos (shove-bits (checksum *encode-buffer* :position start :length (* ipv4-no-options-hlen 4)) 16)))))) ;;;## UDP ;;; RFC 768 (defstruct (udp-header (:conc-name #:udp-header.)) (src-port nil :type (or null (unsigned-byte 16))) (dest-port nil :type (or null (unsigned-byte 16))) (length nil :type (or null (unsigned-byte 16))) (checksum nil :type (or null (unsigned-byte 16)))) (defun grab-udp-header (&optional src-ip dest-ip) "Grab a UDP header and call FUNCTION with each part. The checksum can only be checked if the SRC-IP and DEST-IP fields from the IPv4 header are supplied." (let ((struct (make-udp-header)) (header-start (bit-octet *decode-position*)) checksum length) (flet ((header (name value) (setf (slot-value struct name) value))) (header 'src-port (grab-bits 16)) (header 'dest-port (grab-bits 16)) (header 'length (setf length (grab-bits 16))) (header 'checksum (setf checksum (grab-bits 16))) (when (and src-ip dest-ip) (unless (zerop checksum) ; checksum is optional (let* ((init (- (udp-pseudo-header-checksum-acc src-ip dest-ip length) checksum)) (computed-checksum (checksum *decode-buffer* :position header-start :length length :initial init))) (unless (eql checksum computed-checksum) (error "Bad checksum: Got ~D, computed ~D." checksum computed-checksum)))))) struct)) (defun udp-pseudo-header-checksum-acc (src-ip dest-ip udp-length) (+ (checksum-acc-ipv4-address src-ip) (checksum-acc-ipv4-address dest-ip) (lookup :udp ipv4-protocol-names :reversep t) udp-length)) (defun shove-udp-header (header src-ip dest-ip) "Shove a UDP header. SRC-IP and DEST-IP are from the outer IPv4 header." (with-slots (src-port dest-port checksum) header (let ((start-pos (encoding-position)) length-pos checksum-pos) (shove-bits src-port 16) (shove-bits dest-port 16) (setf length-pos (encoding-position)) (shove-bits 0 16) (setf checksum-pos (encoding-position)) (shove-bits 0 16) (lambda () (let ((length (- (length *encode-buffer*) start-pos))) (with-buffer-patch length-pos (shove-bits length 16)) (let ((csum (checksum *encode-buffer* :position start-pos :initial (udp-pseudo-header-checksum-acc src-ip dest-ip length)))) (with-buffer-patch checksum-pos (shove-bits csum 16)))))))) ;;;# Checksum computation ;;; ;;; The TCP/IP protocols use 16-bit ones-complement checksums. See ;;; RFC1071 for details. (defun checksum (buffer &key (position 0) (length (- (length buffer) position)) (initial 0) (finish t)) "Compute a checksum using normal twos-complement arithmetic. The buffer is treated as a sequence of 16-bit big-endian numbers." (declare (type buffer buffer)) (let ((last-pos (+ position (1- length))) (acc initial)) (do ((msb-pos position (+ msb-pos 2)) (lsb-pos (1+ position) (+ lsb-pos 2))) ((> msb-pos last-pos)) (let ((msb (aref buffer msb-pos)) (lsb (if (> lsb-pos last-pos) 0 (aref buffer lsb-pos)))) (incf acc (dpb msb (byte 8 8) lsb)))) (if finish (finish-checksum acc) acc))) (defun finish-checksum (n) "Convert N into an unsigned 16-bit ones-complement number. The result is a bit-pattern also represented as an integer." (let* ((acc (+ (ldb (byte 16 16) n) (ldb (byte 16 0) n))) (acc (+ acc (ldb (byte 16 16) acc)))) (logxor #xFFFF (ldb (byte 16 0) acc)))) (defun checksum-acc-ipv4-address (address) "Return the partial checksum accumulated from an IPv4 address." (checksum (ipv4-address.octets address) :finish nil)) ;;;# Decoding driver (defvar *previous-header* nil "Bound to the previously decoded header. Some protocols (e.g. UDP) need to retrieve fields from their enclosing protocol's header.") (defun decode-headers (buffer) "Return a list of decoded headers from BUFFER" (with-buffer-input buffer (let* ((headers (grab-more-headers (grab-header :ethernet))) (rest (grab-rest))) (if (zerop (length rest)) headers (append headers (list rest)))))) (defun grab-more-headers (header) "Accumulate HEADER and continue decoding the rest." (if (member (type-of header) '(ethernet-header ipv4-header)) (let ((*previous-header* header) (inner-protocol (slot-value header 'protocol))) (cons header (grab-more-headers (grab-header inner-protocol)))) ;; This is the last header we know how to decode. (list header))) (defun grab-header (protocol) "Grab and return the header of PROTOCOL." (case protocol (:ethernet (grab-ethernet-header)) (:arp (grab-arp-header)) (:ipv4 (grab-ipv4-header)) (:udp (let ((src-ip (slot-value *previous-header* 'source)) (dest-ip (slot-value *previous-header* 'dest))) (grab-udp-header src-ip dest-ip))))) ;;;# Encoding driver ;;; ;;; To encode a packet we "shove" each element into a vector and then ;;; apply the "touchup functions". (defun encode-headers (headers) (let (src-ip dest-ip) (flet ((shove-element (e) ;; Shove E into the encoding vector and return a touchup. (etypecase e (buffer (shove-vector e) (constantly nil)) (ethernet-header (shove-ethernet-header e)) (arp-header (shove-arp-header e)) (ipv4-header (setf src-ip (ipv4-header.source e)) (setf dest-ip (ipv4-header.dest e)) (shove-ipv4-header e)) (udp-header (assert (and src-ip dest-ip)) (shove-udp-header e src-ip dest-ip))))) (with-buffer-output () (let ((touchups '())) (dolist (e headers) (push (shove-element e) touchups)) (mapc #'funcall touchups)))))) ;;;# Sample packets (defparameter *arp-packet* (coerce #(255 255 255 255 255 255 0 8 116 228 110 188 8 6 0 1 8 0 6 4 0 1 0 8 116 228 110 188 192 168 128 44 0 0 0 0 0 0 192 168 128 1) 'buffer) "An ethernet frame containing an ARP request.") (defparameter *udp-packet* (coerce #(255 255 255 255 255 255 0 8 116 228 110 188 8 0 69 0 0 124 0 0 64 0 64 17 183 244 192 168 128 44 192 168 128 255 128 117 0 111 0 104 5 206 20 15 249 61 0 0 0 0 0 0 0 2 0 1 134 160 0 0 0 2 0 0 0 5 0 0 0 1 0 0 0 24 64 158 126 39 0 0 0 4 100 111 100 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 134 164 0 0 0 2 0 0 0 2 0 0 0 16 0 0 0 12 98 108 117 101 116 97 105 108 46 99 111 109) 'buffer) "An ethernet frame containing a UDP packet.") (defun test () (decode-test) (encode-test) 'ok) (defun decode-test () "Test that the sample packets are decoded correctly." (let* ((arp-headers (decode *arp-packet*)) (udp-headers (decode *udp-packet*))) (check-headers arp-headers '((ETHERNET-HEADER ((DEST . #e"FF:FF:FF:FF:FF:FF") (SOURCE . #e"00:08:74:E4:6E:BC") (PROTOCOL . :ARP))) (ARP-HEADER ((HARDWARE-TYPE . 1) (PROTOCOL-TYPE . 2048) (HARDWARE-LENGTH . 6) (PROTOCOL-LENGTH . 4) (OPERATION . :REQUEST) (SENDER-HA . #e"00:08:74:E4:6E:BC") (SENDER-IP . @192.168.128.44) (TARGET-HA . #e"00:00:00:00:00:00") (TARGET-IP . @192.168.128.1))))) (check-headers udp-headers `((ETHERNET-HEADER ((DEST . #e"FF:FF:FF:FF:FF:FF") (SOURCE . #e"00:08:74:E4:6E:BC") (PROTOCOL . :IPV4))) (IPV4-HEADER ((VERSION . 4) (HLEN . 5) (TOS . 0) (TOTAL-LEN . 124) (ID . 0) (FLAGS . 2) (FRAGMENT-OFFSET . 0) (TTL . 64) (PROTOCOL . :UDP) (CHECKSUM . 47092) (SOURCE . @192.168.128.44) (DEST . @192.168.128.255))) (UDP-HEADER ((SRC-PORT . 32885) (DEST-PORT . 111) (LENGTH . 104) (CHECKSUM . 1486))) ,(coerce #(20 15 249 61 0 0 0 0 0 0 0 2 0 1 134 160 0 0 0 2 0 0 0 5 0 0 0 1 0 0 0 24 64 158 126 39 0 0 0 4 100 111 100 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 134 164 0 0 0 2 0 0 0 2 0 0 0 16 0 0 0 12 98 108 117 101 116 97 105 108 46 99 111 109) 'buffer))))) (defun check-headers (headers specs) "Check that HEADERS agrees element-wise with SPECS. SPECS is a list of specifications of what a header should contain." (flet ((check (header spec) ;; Raise an error if HEADER doesn't match SPEC. (loop for (slot . value) in (second spec) do (unless (equalp (slot-value header slot) value) (error "Slot ~A: Expected ~A, got ~A." slot value (slot-value header slot))) always t))) (unless (and (null headers) (null specs)) (let ((header (first headers)) (spec (first specs))) (if (and (typep header 'buffer) (typep spec 'buffer)) (unless (equalp header spec) (error "Mismatch in binary parts.")) (progn (unless (eq (type-of header) (first spec)) (error "Header type mismatch: ~A ~A" (type-of header) (first spec))) (check header spec) (check-headers (rest headers) (rest specs)))))))) (defun encode-test () "Check that (encode (decode PACKET)) <=> identity." (assert (and (equalp *udp-packet* (encode (decode *udp-packet*))) (equalp *arp-packet* (encode (decode *arp-packet*)))))) (defun bench (n) "Show how long it takes to decode and re-encode 10^N UDP packets." (time (dotimes (i (expt 10 n)) (encode (decode *udp-packet*))))) ;;;# Exporting structures ;;; ;;; My pet hate is explicitly enumerating all the accessors for ;;; structures in export declarations. Instead we do a little ;;; introspection to enumerate them automatically, and jump through ;;; some hoops with `defpackage' (above) to avoid warnings. (eval-when (:compile-toplevel :load-toplevel) (defun structure-exports () "The list of defstruct-defined symbols that we want to export." (apply #'append (mapcar #'structure-symbol-names '(ethernet-header ethernet-address arp-header ipv4-header ipv4-address udp-header)))) (defun structure-symbol-names (name) "Return all the interesting symbols generated by DEFSTRUCT for NAME. Assumes a FOO type name, MAKE-FOO constructor, and FOO-P predicate to avoid excessively low-level introspection." (list* name (find-symbol (format nil "~A-P" name)) (find-symbol (format nil "MAKE-~A" name)) (structure-accessors name))) (defun structure-accessors (name) (mapcar #'pcl::slot-definition-defstruct-accessor-symbol (pcl:class-direct-slots (find-class name)))) (export (structure-exports)))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

small-cl-src