- small-cl-src@common-lisp.net - mailman3.common-lisp.net

[Small-cl-src] defun-with-cache
by Ben Hyde 10 Dec '05

10 Dec '05

This is a lark. Given a function: (defun f (...) ...) You can rewrite that into: (defun-with-cache f (...) ...) at which point a second call upon f with the same arguments will return the values returned the first time. You can clear the cache by calling. (clear-cache-of-function 'f) If I was to guess where this is likely to have a bug I'd pick rip- apart-arglist; who's job is to handle &optional, &rest, &keys, etc. If I was to pick the part likely to make the casual reader's brain hurt it would be body of defun-with-cache, which was pure fun to write. It's fine if F returns multiple values. This does what I need in the code where I'm using it, so "I think I'm happy." - ben (defun rip-apart-arglist (arglist) (loop with binds = nil with call = nil with apply? = nil with keys? = nil finally (return (values (nreverse binds) (if apply? (nreverse (cons apply? call)) (nreverse call)) apply?)) for arg in arglist do (flet ((accumulate (var) (push var binds) (when (eq t apply?) (setf apply? var) (return-from accumulate)) (when keys? (push (intern (symbol-name var) *keywork-package*) call)) (push var call))) (cond ((consp arg) (accumulate (first arg))) ((eq arg '&aux) (finish)) ((eq arg '&rest) (setf apply? t)) ((eq arg '&optional) (setf apply? t)) ((eq arg '&allow-other-keys) (setf apply? t)) ((eq arg '&key) (setf keys? t)) ((symbolp arg) (accumulate arg)))))) (defmacro cache-of-function (function-name) `(get ,function-name :cache-of-function)) (defun clear-cache-of-function (function-name) (clrhash (cache-of-function function-name))) (defmacro defun-with-cache (name args &body body) (multiple-value-bind (binding call apply?) (rip-apart-arglist args) `(let ((#1=#:cache (make-hash-table :test #'equal))) (setf (cache-of-function ',name) #1#) (defun ,name ,args (flet ((,name ,args ,@body)) (let ((#2=#:key (list ,@binding))) (values-list (or (gethash #2# #1#) (setf (gethash #2# #1#) (multiple-value-list ,@(if apply? `((apply #',name ,@call)) `((,name ,@call)))))))))))))

1 0

[Small-cl-src] RE: a Clisp problem (Xie Wen Sheng)
by Xie Wen Sheng 05 Dec '05

05 Dec '05

Hi, All: I got a solution from comp.lang.lisp: Pascal Bourguignon: (DEFUN COMBINE (ARGS) " RETURN: (elt args 0) x (elt args 1) x ... x (elt args (1- (length args))) = the set of tuples built taking one item in order from each list in args. EXAMPLE: (COMBINE '((WWW FTP) (EXA) (COM ORG))) --> ((WWW EXA COM) (WWW EXA ORG) (FTP EXA COM) (FTP EXA ORG)) " (COND ((NULL ARGS) '(NIL)) ((NULL (CAR ARGS)) (COMBINE (CDR ARGS))) ((CONSP (CAR ARGS)) (MAPCAN (LAMBDA (ITEM) (COMBINE (cons ITEM (CDR ARGS)))) (CAR ARGS))) (T (MAPCAN (LAMBDA (REST) (LIST (CONS (CAR ARGS) REST))) (COMBINE (CDR ARGS)))))) Tron3k: (defun combine (lst) (if (endp lst) (list '()) (loop with crest = (combine (rest lst)) for item in (first lst) nconc (loop for items in crest collect (cons item items))))) Thank you all. XIE Wensheng -----Original Message----- From: small-cl-src-bounces(a)hexapodia.net [mailto:small-cl-src-bounces@hexapodia.net]On Behalf Of small-cl-src-request(a)hexapodia.net Sent: Saturday, December 03, 2005 8:00 PM To: small-cl-src(a)hexapodia.net Subject: Small-cl-src Digest, Vol 10, Issue 1 Send Small-cl-src mailing list submissions to small-cl-src(a)hexapodia.net To subscribe or unsubscribe via the World Wide Web, visit http://www.hexapodia.net/mailman/listinfo/small-cl-src or, via email, send a message with subject or body 'help' to small-cl-src-request(a)hexapodia.net You can reach the person managing the list at small-cl-src-owner(a)hexapodia.net When replying, please edit your Subject line so it is more specific than "Re: Contents of Small-cl-src digest..." Today's Topics: 1. a Clisp problem (Xie Wen Sheng) ---------------------------------------------------------------------- Message: 1 Date: Mon, 28 Nov 2005 16:22:54 +0800 From: "Xie Wen Sheng" <wen-sheng.xie(a)thomson.net> Subject: [Small-cl-src] a Clisp problem To: <small-cl-src(a)hexapodia.net> Message-ID: <CE1F1B158B2B1C4080BA3F114B158B5B019013(a)szntsmail01.ap.thmulti.com> Content-Type: text/plain; charset="iso-8859-1" Hi ,All I'm new to lisp, using GNU Clisp. I have a problem when I do some Lisp programming training. For example, for the list (a (b1 b2) c (d1 d2) (e1 e2 e3) f), I need a function to return all the possible combinations like: ((a b1 c d1 e1 f) (a b1 c d1 e2 f) (a b1 c d1 e3 f) (a b1 c d2 e1 f) (a b1 c d2 e2 f) (a b1 c d2 e3 f) (a b2 c d1 e1 f) (a b2 c d1 e2 f) (a b2 c d1 e3 f) (a b2 c d2 e1 f) (a b2 c d2 e2 f) (a b2 c d2 e3 f)) My tries trended to be unsuccessful. Is it too easy to ask this here? If so, where is the forum for people like me? best regards, XIE Wensheng ------------------------------ _______________________________________________ Small-cl-src mailing list Small-cl-src(a)hexapodia.net http://www.hexapodia.net/mailman/listinfo/small-cl-src End of Small-cl-src Digest, Vol 10, Issue 1 *******************************************

1 0

[Small-cl-src] a Clisp problem
by Xie Wen Sheng 28 Nov '05

28 Nov '05

Hi ,All I'm new to lisp, using GNU Clisp. I have a problem when I do some Lisp programming training. For example, for the list (a (b1 b2) c (d1 d2) (e1 e2 e3) f), I need a function to return all the possible combinations like: ((a b1 c d1 e1 f) (a b1 c d1 e2 f) (a b1 c d1 e3 f) (a b1 c d2 e1 f) (a b1 c d2 e2 f) (a b1 c d2 e3 f) (a b2 c d1 e1 f) (a b2 c d1 e2 f) (a b2 c d1 e3 f) (a b2 c d2 e1 f) (a b2 c d2 e2 f) (a b2 c d2 e3 f)) My tries trended to be unsuccessful. Is it too easy to ask this here? If so, where is the forum for people like me? best regards, XIE Wensheng

1 0

[Small-cl-src] What would var+++ be in CL?
by Ingvar 06 Jul '05

06 Jul '05

;;; Possibly a tad naive, but... (defmacro post-incf (form &optional (increment 1)) (let ((value (gensym "POST-INCF"))) `(let ((,value ,form)) (prog1 ,value (setf ,form (+ ,value ,increment))))))

2 1

[Small-cl-src] "Fast floats" macro(s)
by Ingvar 15 Jun '05

15 Jun '05

;;; There recently was a discussion about using arrays with suitably-declared ;;; element-type s to store floats without needing boxing and unboxing. ;;; This is obviously quite a hassle, as and when one wants to use. ;;; ;;; But, this is lisp and macros are (as always) ready to leap to the rescue. ;;; This code is Copyright Ingvar Mattsson, 2005 <ingvar(a)hexapodia.net> ;;; You are free to use and/or modify this code as you see fit, as long ;;; as this comment block is retained and modifications noted by at least ;;; the modifyer's name. (defpackage #:net.hexapodia.fastfloats (:nicknames #:fastfloats) (:use #:cl) (:export #:double-float-let #:single-float-let :float-let)) (in-package #:net.hexapodia.fastfloats) (defun float-let-expander (type initform body) (let ((syms (loop for spec in initform for n from 0 if (symbolp spec) collect (cons spec n) else collect (cons (car spec) n))) (inits (loop for spec in initform unless (symbolp spec) collect (list (gensym) spec))) (storage (gensym))) `(let ,(loop for (sym spec) in inits collect (list sym (cadr spec))) (let ((,storage (make-array ,(length syms) :element-type ',type :initial-element (coerce 0.0 ',type)))) (symbol-macrolet ,(loop for (sym . n) in syms collect (list sym (list 'aref storage n))) ; Init section ,@(loop for (sym val) in inits collect (list 'setf (car val) sym)) ,@body))))) (defmacro double-float-let (initform &body body) (float-let-expander 'double-float initform body)) (defmacro single-float-let (initform &body body) (float-let-expander 'single-float initform body)) (defmacro float-let (initform &body body) (float-let-expander *read-default-float-format* initform body)) ;;; //Ingvar

1 0

[Small-cl-src] quasi-standard method combination
by Marco Baringer 04 Nov '04

04 Nov '04

(define-method-combination quasi-standard (&key (around-order :most-specific-first) (before-order :most-specific-first) (primary-order :most-specific-first) (after-order :most-specific-last)) ((around (:around)) (before (:before)) (primary () :required-t) (after (:after))) "Same semantics as standard method combination but the order of method application is settable. This method combination takes four arguments which allow you to change the order in which around, before, primary and after methods are called. The values of the keyword parameters must all be either :most-specific-last or :most-specific-first." (labels ((effective-order (methods order) (ecase order (:most-specific-first methods) (:most-specific-last (reverse methods)))) (call-methods (methods) (mapcar (lambda (meth) `(call-method ,meth)) methods))) (let* (;; reorder the methods based on the -order arguments (around (effective-order around around-order)) (before (effective-order before before-order)) (primary (effective-order primary primary-order)) (after (effective-order after after-order)) ;; inital value of the effective call is a call its primary ;; method(s) (form (case (length primary) (1 `(call-method ,(first primary))) (t `(call-method ,(first primary) ,(rest primary)))))) (when before ;; wrap FORM in calls to its before methods (setf form `(progn ,@(call-methods before) ,form))) (when after ;; wrap FORM in calls to its after methods (setf form `(multiple-value-prog1 ,form ,@(call-methods after)))) (when around ;; wrap FORM in calls to its around methods (setf form `(call-method ,(first around) (,@(rest around) (make-method ,form))))) form))) -- -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] m-v-b* and d-b* (auto-ignoring arguments called _)
by Andreas Fuchs 02 Nov '04

02 Nov '04

;;; Hi, ;;; ;;; I hope this code makes a few functions (like decode-universal-time) ;;; more useful. Each of these functions replaces variables with a ;;; symbol-name of _ with a (declare (ignore))d gensym. ;;; ;;; I'm sure everybody has already written something similar. ;;; "Somebody should write a CLRFI for that" (-: (require :iterate) ;; Yeah, sorry.. the solution using LOOP was ugly as hell. (defun replace-binds (binds) (iterate (for bind in binds) (typecase bind (cons (multiple-value-bind (result* ignore*) (replace-binds bind) (collecting result* into result) (appending ignore* into ignore))) (t (if (string-equal bind '_) (let ((sym (gensym))) (collect sym into result) (collect sym into ignore)) (collect bind into result)))) (finally (return (values result ignore))))) (defmacro destructuring-bind* (bind-list obj &rest body) (multiple-value-bind (binds ignores) (replace-binds bind-list) `(destructuring-bind ,binds ,obj (declare (ignore ,@ignores)) ,@body))) (defmacro multiple-value-bind* (bind-list obj &rest body) (multiple-value-bind (binds ignores) (replace-binds bind-list) `(multiple-value-bind ,binds ,obj (declare (ignore ,@ignores)) ,@body))) ;;; Have fun, -- Andreas Fuchs, <asf(a)boinkor.net>, asf(a)jabber.at, antifuchs

1 0

[Small-cl-src] Netflow log reader (for the flowd logger from www.mindrot.org)
by Ingvar 20 Oct '04

20 Oct '04

;;; This is (C) Ingvar Mattsson, 2004 ;;; <ingvar(a)hexapodia.net> ;;; This code uses the file format specification outlined in store.h ;;; in the netflow logger daemon downloadable from ;;; http://www.mindrot.org/flowd.html ;;; ;;; This code is available under the BSD license, please preserve the ;;; relevant copyright notices. ;;; ;;; The store.h file is: ;;; /* ;;; * Copyright (c) 2004 Damien Miller <djm(a)mindrot.org> ;;; * ;;; * Permission to use, copy, modify, and distribute this software for any ;;; * purpose with or without fee is hereby granted, provided that the above ;;; * copyright notice and this permission notice appear in all copies. ;;; * ;;; * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES ;;; * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF ;;; * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ;;; * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES ;;; * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ;;; * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ;;; * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ;;; */ (defpackage #:flowd (:use #:cl) (:shadow #:tag #:stream) (:export #:+store-magic+ #:+store-version+ #:store-field-tag #:store-field-recv-time #:store-field-proto-flags-tos #:store-field-agent-addr4 #:store-field-agent-addr6 #:store-field-src-addr4 #:store-field-src-addr6 #:store-field-dst-addr4 #:store-field-dst-addr6 #:store-field-gateway-addr4 #:store-field-gateway-addr6 #:store-field-srcdst-port #:store-field-packets #:store-field-octets #:store-field-if-indices #:store-field-agent-info #:store-field-flow-times #:store-field-as-info #:store-field-flow-engine-info #:store-field-crc32 #:store-field-all #:open-log #:read-flow #:close-log #:fields #:tag #:recv-time #:proto-flags-tos #:agent-addr #:src-addr #:dst-addr #:gateway-addr #:src-port #:dst-port #:packets #:if-index-in #:if-index-out #:sys-uptime-ms #:time-sec #:time-nanosec #:netflow-version #:flow-start #:flow-finish #:src-as #:dst-as #:src-mask #:dst-mask #:engine-type #:engine-id #:flow-sequence #:src-net #:dst-net #:octets #:packets #:start-time #:format-ipv4)) (in-package #:flowd) (defvar *ipv4-netmasks* (apply #'vector (loop for n from 0 to 32 for mask = 0 then (logior #x80000000 (ash mask -1)) collect mask))) (defconstant +store-magic+ #x012cf047) (defconstant +store-version+ 2) (defconstant +store-field-tag+ (ash 1 0)) (defconstant +store-field-recv-time+ (ash 1 1)) (defconstant +store-field-proto-flags-tos+ (ash 1 2)) (defconstant +store-field-agent-addr4+ (ash 1 3)) (defconstant +store-field-agent-addr6+ (ash 1 4)) (defconstant +store-field-src-addr4+ (ash 1 5)) (defconstant +store-field-src-addr6+ (ash 1 6)) (defconstant +store-field-dst-addr4+ (ash 1 7)) (defconstant +store-field-dst-addr6+ (ash 1 8)) (defconstant +store-field-gateway-addr4+ (ash 1 9)) (defconstant +store-field-gateway-addr6+ (ash 1 10)) (defconstant +store-field-srcdst-port+ (ash 1 11)) (defconstant +store-field-packets+ (ash 1 12)) (defconstant +store-field-octets+ (ash 1 13)) (defconstant +store-field-if-indices+ (ash 1 14)) (defconstant +store-field-agent-info+ (ash 1 15)) (defconstant +store-field-flow-times+ (ash 1 16)) (defconstant +store-field-as-info+ (ash 1 17)) (defconstant +store-field-flow-engine-info+ (ash 1 18)) (defconstant +store-field-crc32+ (ash 1 30)) (defconstant +store-field-all+ (1- (ash 1 19))) (defclass store-header () ((magic :reader magic :initarg :magic) (version :reader version :initarg :version) (start-time :reader start-time :initarg :start-time) (flags :reader flags :initarg :flags) (stream :reader stream :initarg :stream) )) (defclass flow () ((fields :accessor fields :initarg :fields :initform nil) (tag :accessor tag :initarg :tag :initform nil) (recv-time :accessor recv-time :initarg :recv-time :initform nil) (tcp-flags :accessor tcp-flags :initarg :tcp-flags :initform nil) (protocol :accessor protocol :initarg :protocol :initform nil) (tos :accessor tos :initarg :tos :initform nil) (agent-addr :accessor agent-addr :initarg :agent-addr :initform nil) (src-addr :accessor src-addr :initarg :src-addr :initform nil) (dst-addr :accessor dst-addr :initarg :dst-addr :initform nil) (gateway-addr :accessor gateway-addr :initarg :gateway-addr :initform nil) (src-port :accessor src-port :initarg :src-port :initform nil) (dst-port :accessor dst-port :initarg :dst-port :initform nil) (packets :accessor packets :initarg :packets :initform nil) (octets :accessor octets :initarg :octets :initform nil) (if-index-in :accessor if-index-in :initarg :if-index-in :initform nil) (if-index-out :accessor if-index-out :initarg :if-index-out :initform nil) (sys-uptime-ms :accessor sys-uptime-ms :initarg :sys-uptime-ms :initform nil) (time-sec :accessor time-sec :initarg :time-sec :initform nil) (time-nanosec :accessor time-nanosec :initarg :time-nanosec :initform nil) (netflow-version :accessor netflow-version :initarg :netflow-version :initform nil) (flow-start :accessor flow-start :initarg :flow-start :initform nil) (flow-finish :accessor flow-finish :initarg :flow-finish :initform nil) (src-as :accessor src-as :initarg :src-as :initform nil) (dst-as :accessor dst-as :initarg :dst-as :initform nil) (src-mask :accessor src-mask :initarg :src-mask :initform nil) (dst-mask :accessor dst-mask :initarg :dst-mask :initform nil) (engine-type :accessor engine-type :initarg :engine-type :initform nil) (engine-id :accessor engine-id :initarg :engine-id :initform nil) (flow-sequence :accessor flow-sequence :initarg :flow-sequence :initform nil) )) (defclass ipaddr () ((address :accessor address :initarg :address))) (defclass ipv4 (ipaddr) ()) (defclass ipv6 (ipaddr) ()) (defun make-ipv4 (addr) "This function is currently a no-op" ;;(make-instance 'ipv4 :address addr) (identity addr) ) (defun make-ipv6 (addr) "This function is currently a no-op" ;;(make-instance 'ipv6 :address addr) (identity addr) ) (defmacro when-flagged (flag &body body) "Checks if a given flag is set. The flag field is expected to be named FIELDS and is for use inside READ-FLOW only!" `(when (not (zerop (logand fields ,flag))) ,@body)) (defun read-n-bytes (stream n) "Read from STREAM a total of N bytes, mung them together as a single integer. Expects 8-bit bytes." (let ((acc 0)) (loop for r from 1 to n do (setf acc (logior (ash acc 8) (read-byte stream)))) acc)) (defun read-flow (flow-header &optional flow-obj) "(read-flow <flow-header> &optional flow-object) This function reads one flow entry from a log file (return value from OPEN-LOG) and returns it. If a flow object is passed in as an optional parameter, this flow object is re-used for storage instead of allocating a new instance." (let ((stream (stream flow-header))) (let ((fields (read-n-bytes stream 4))) (let ((flow (if flow-obj (progn (setf (fields flow-obj) fields) flow-obj) (make-instance 'flow :fields fields))) pad) (when-flagged +store-field-tag+ (setf (tag flow) (read-n-bytes stream 4))) (when-flagged +store-field-recv-time+ (setf (recv-time flow) (read-n-bytes stream 4))) (when-flagged +store-field-proto-flags-tos+ (setf (tcp-flags flow) (read-n-bytes stream 1)) (setf (protocol flow) (read-n-bytes stream 1)) (setf (tos flow) (read-n-bytes stream 1)) (setf pad (read-n-bytes stream 1))) (when-flagged +store-field-agent-addr4+ (setf (agent-addr flow) (make-ipv4 (read-n-bytes stream 4)))) (when-flagged +store-field-agent-addr6+ (setf (agent-addr flow) (make-ipv6 (read-n-bytes stream 16)))) (when-flagged +store-field-src-addr4+ (setf (src-addr flow) (make-ipv4 (read-n-bytes stream 4)))) (when-flagged +store-field-src-addr6+ (setf (src-addr flow) (make-ipv6 (read-n-bytes stream 16)))) (when-flagged +store-field-dst-addr4+ (setf (dst-addr flow) (make-ipv4 (read-n-bytes stream 4)))) (when-flagged +store-field-dst-addr6+ (setf (dst-addr flow) (make-ipv6 (read-n-bytes stream 16)))) (when-flagged +store-field-gateway-addr4+ (setf (gateway-addr flow) (make-ipv4 (read-n-bytes stream 4)))) (when-flagged +store-field-gateway-addr6+ (setf (gateway-addr flow) (make-ipv6 (read-n-bytes stream 16)))) (when-flagged +store-field-srcdst-port+ (setf (src-port flow) (read-n-bytes stream 2)) (setf (dst-port flow) (read-n-bytes stream 2))) (when-flagged +store-field-packets+ (setf (packets flow) (read-n-bytes stream 8))) (when-flagged +store-field-octets+ (setf (octets flow) (read-n-bytes stream 8))) (when-flagged +store-field-if-indices+ (setf (if-index-in flow) (read-n-bytes stream 2)) (setf (if-index-out flow) (read-n-bytes stream 2))) (when-flagged +store-field-agent-info+ (setf (sys-uptime-ms flow) (read-n-bytes stream 4)) (setf (time-sec flow) (read-n-bytes stream 4)) (setf (time-nanosec flow) (read-n-bytes stream 4)) (setf (netflow-version flow) (read-n-bytes stream 2)) (setf pad (read-n-bytes stream 2))) (when-flagged +store-field-flow-times+ (setf (flow-start flow) (read-n-bytes stream 4)) (setf (flow-finish flow) (read-n-bytes stream 4))) (when-flagged +store-field-as-info+ (setf (src-as flow) (read-n-bytes stream 2)) (setf (dst-as flow) (read-n-bytes stream 2)) (setf (src-mask flow) (read-n-bytes stream 1)) (setf (dst-mask flow) (read-n-bytes stream 1)) (setf pad (read-n-bytes stream 2))) (when-flagged +store-field-flow-engine-info+ (setf (engine-type flow) (read-n-bytes stream 1)) (setf (engine-id flow) (read-n-bytes stream 1)) (setf pad (read-n-bytes stream 2)) (setf (flow-sequence flow) (read-n-bytes stream 4))) (when-flagged +store-field-crc32+ (setf pad (read-n-bytes stream 4))) flow)))) (defun open-log (file) "(open-log <file name> This function opens a new log file and returns a header structure containing the relevant file header information." (let ((stream (open file :element-type '(unsigned-byte 8) :direction :input))) (let ((magic (read-n-bytes stream 4))) (let ((version (read-n-bytes stream 4))) (let ((start-time (read-n-bytes stream 4))) (let ((flags (read-n-bytes stream 4))) (make-instance 'store-header :magic magic :version version :start-time start-time :flags flags :stream stream))))))) (defun close-log (flow) "(close-log flow) This function closes the log file associated with a storage header." (close (stream flow))) (defmacro formatted-addr (flow-obj slot) (let ((flags (case slot (dst-addr (list +store-field-dst-addr4+ +store-field-dst-addr6+)) (src-addr (list +store-field-src-addr4+ +store-field-src-addr6+)) (gateway-addr (list +store-field-gateway-addr4+ +store-field-gateway-addr6+)) (agent-addr (list +store-field-agent-addr4+ +store-field-agent-addr6+)))) (flow flow-obj)) `(format-addr ,flow ',flags (,slot ,flow)))) (defun format-addr (flow-obj flags chunk) (let ((flag4 (car flags)) (flag6 (cadr flags)) (fields (fields flow-obj))) (or (when (= flag4 (logand flag4 fields)) (format-ipv4 chunk)) (when (= flag6 (logand flag6 fields)) (format nil "~X" chunk))))) (defun format-ipv4 (chunk &optional stream mask) "(format-ipv4 binary-chunk &optiona stream mask) This function outputs an IPv4 address as a dotted quad to STREAM. If a netmask is passed in, it's outputted with the dotted quad in CIDR notation." (if mask (format stream "~D.~D.~D.~D/~D" (ldb (byte 8 24) chunk) (ldb (byte 8 16) chunk) (ldb (byte 8 8) chunk) (ldb (byte 8 0) chunk) mask) (format stream "~D.~D.~D.~D" (ldb (byte 8 24) chunk) (ldb (byte 8 16) chunk) (ldb (byte 8 8) chunk) (ldb (byte 8 0) chunk)))) (defun src-net (flow-obj &optional (stream nil) (formatted nil)) "(src-net flow-obj &optional stream formatted-p) This function extracts the source network and masks it against the relevant IPv4 netmask and returns the network part. If given a STREAM and FORMATTED-P is not null, the resulting netblock is emitted using FORMAT-IPV4 to the indicated stream." (let ((bitmask (logior +store-field-as-info+ +store-field-src-addr4+))) (when (= bitmask (logand (fields flow-obj) bitmask)) (let ((masklen (src-mask flow-obj))) (let ((netmask (aref *ipv4-netmasks* masklen))) (let ((netblock (logand (src-addr flow-obj) netmask))) (if formatted (format-ipv4 netblock stream masklen) netblock))))))) (defun dst-net (flow-obj &optional (stream nil) (formatted nil)) "(dst-net flow-obj &optional stream formatted-p) This function extracts the destination network and masks it against the relevant IPv4 netmask and returns the network part. If given a STREAM and FORMATTED-P is not null, the resulting netblock is emitted using FORMAT-IPV4 to the indicated stream." (let ((bitmask (logior +store-field-as-info+ +store-field-dst-addr4+))) (when (= bitmask (logand (fields flow-obj) bitmask)) (let ((masklen (dst-mask flow-obj))) (let ((netmask (aref *ipv4-netmasks* masklen))) (let ((netblock (logand (dst-addr flow-obj) netmask))) (if formatted (format-ipv4 netblock stream masklen) netblock))))))) -- //Ingvar

1 0

[Small-cl-src] (loop for (key value) in-hash table do ...)
by Helmut Eller 20 Oct '04

20 Oct '04

;;; A little hack to get nicer syntax for hash-tables with LOOP. ;;; Works in CMUCL. ;;; ;;; Example: #| ;; cons up some random hash table (setq *htab* (let ((htab (make-hash-table))) (dotimes (i 50 htab) (setf (gethash i htab) (cons (random 200) (random (1+ i))))))) ;; convert it to a list (loop for (i (r1 . r2)) in-hash *htab* collect (list i r1 r2)) |# (in-package :ansi-loop) ;; Add a for-in-hash clause to loop. ;; (loop for (key value) in-hash <hashtable> ...) (defun loop-for-in-hash (key-val htab-form type) (declare (ignore type)) (destructuring-bind (key val) key-val (let ((more? (loop-gentemp 'more?)) (next (loop-gentemp 'next)) (htab (loop-gentemp 'htab)) (key-tmp (loop-gentemp 'key-tmp)) (val-tmp (loop-gentemp 'val-tmp))) (loop-make-variable htab htab-form nil) ; bind htab first (loop-make-variable more? nil nil) (loop-make-variable key-tmp nil nil) (loop-make-variable val-tmp nil nil) (push `(with-hash-table-iterator (,next ,htab)) *loop-wrappers*) (loop-make-iteration-variable key nil 't) (loop-make-iteration-variable val nil 't) (list `(progn (multiple-value-setq (,more? ,key-tmp ,val-tmp) (,next)) (not ,more?)) (list key key-tmp val val-tmp))))) (let* ((env *loop-ansi-universe*) (htab (loop-universe-for-keywords env))) (setf (gethash (string :in-hash) htab) (list 'loop-for-in-hash)))

1 0

[Small-cl-src] "simple" X11 clipboard client
by Christophe Rhodes 19 Oct '04

19 Oct '04

#| Howdy, I found myself wondering how hard it would be to make an X client which plays nice with select-and-paste (as seen by all the other X clients out there). The answer seems to be "quite hard", but here's a step along the road: a translation of some C test code, yielding a proof-of-concept clipboard client. Pastes both to and from the client work: a paste of text to the client yields printed messages to the lisp's standard output, and pastes while the client owns PRIMARY (left-click in the window) cause a silly piece of text to be pasted. Christophe |# ;;; This is a pretty direct translation of the Xlib selection test ;;; program by Tor Andersson found at ;;; <http://ghostscript.com/~tor/repos/Klipp/x11clipboard.c>, with ;;; minor enhancements: ;;; ;;; * gdk requestors apparently unconditionally request UTF8_STRING ;;; selections without checking the TARGETS list of the selection ;;; owner -- and apparently even never request anything else. This ;;; seems to be in contradiction with the freedesktop.org draft ;;; specification at ;;; <http://www.pps.jussieu.fr/~jch/software/UTF8_STRING/UTF8_STRING.text> ;;; (linked from <http://freedesktop.org/Standards>), but this is ;;; the real world and we have to live in it. It would be nice if ;;; someone in the freedesktop community could resolve this. ;;; ;;; * the original C code, in the XSendEvent call, has an event mask ;;; of SelectionNotify. SelectionNotify is not an event mask at ;;; all, however: but the code works "by accident" because ;;; SelectionNotify happens to have value 31, which has enough bits ;;; flipped on that most clients select on at least one of those ;;; events. This bug is fixed below. ;;; ;;; As ever with these things, the divisions in intellectual property ;;; between the writer of the original C program, Tor Andersson ;;; (contactable at tor [dot] andersson [at] gmail [dot] com) and the ;;; translator (Christophe Rhodes, csr21 [at] cam [dot] ac [dot] uk) ;;; are murky, probably depend on jurisdiction, and in addition for ;;; such a small work are essentially trivial. To set peoples' minds ;;; at ease, Tor wishes this information to be disseminated as widely ;;; as possible. ;;; Copyright (c) 2004, Christophe Rhodes ;;; ;;; 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 "CLIPBOARD" (:use "CL" "XLIB") (:export "MAIN")) (in-package "CLIPBOARD") ;;; This is "traditional" XLIB style; I don't really know if it's the ;;; best way -- in developing this program, style of XLIB programming ;;; was secondary to achieving First Paste. (defvar *window*) (defvar *time*) (defvar *display*) (defun ownselect () (format t "~&> set-selection-owner~%") (finish-output) (set-selection-owner *display* :primary *window* *time*) (unless (eq *window* (selection-owner *display* :primary)) (write-string "failed to own primary"))) (defun deselect () (format t "~&> unset-selection-owner~%") (finish-output) (set-selection-owner *display* :primary nil *time*) (unless (eq nil (selection-owner *display* :primary)) (write-string "failed to disown primary"))) (defun ask-paste () (format t "~&! deleting properties on window~%") (finish-output) (delete-property *window* :aeclip-target) (delete-property *window* :aeclip-string) (delete-property *window* :aeclip-utf8_string) (delete-property *window* :aeclip-text) (format t "~&> convert-selection TARGETS~%") (finish-output) (convert-selection :primary :targets *window* :aeclip-target) (format t "~&> convert-selection STRING~%") (finish-output) (convert-selection :primary :string *window* :aeclip-string) (format t "~&> convert-selection UTF8_STRING~%") (finish-output) (convert-selection :primary :utf8_string *window* :aeclip-utf8_string) (format t "~&> convert-selection TEXT~%") (finish-output) (convert-selection :primary :text *window* :aeclip-text) nil) (defun recv-paste (property) (multiple-value-bind (data name format) (get-property *window* property) (format t "~&< get-prop ~S " name) (case format (32 (format t "[~{~S~^,~}]" (mapcar (lambda (x) (atom-name *display* x)) data))) (8 (format t "~S" (map 'string 'code-char data))) (t (format t "format=~S data=~S" format data))) (format t "~%") (finish-output) (delete-property *window* property))) (defun send-copy (selection target property requestor time) (case target ;; we are being a little liberal in what we accept here: no ;; requestor should ask us for a UTF8_STRING selection because we ;; don't advertise the capability (see the TARGETS clause below). ;; However, Xt-based requestors appear not to query TARGETS, ;; instead trying UTF8_STRING, COMPOUND_TEXT and STRING in order; ;; Gdk-based requestors don't query TARGETS either, trying just ;; UTF8_STRING (and giving up if the selection owner returns a ;; null property). So pretend that we can send UTF8_STRING ;; selections. ((:string :utf8_string) (format t "~&> sending text data~%") (finish-output) (change-property requestor property "Hello, World (from the CLX clipboard)!" target 8 :transform #'char-code)) (:targets (format t "~&> sending targets list~%") (finish-output) (change-property requestor property '(:targets :string) target 32 :transform (lambda (x) (intern-atom *display* x)))) (t (format t "~&> sending none~%") (finish-output) (setf property nil))) (send-event requestor :selection-notify (make-event-mask :button-press :property-change) :selection selection :target target :property property :time time :event-window requestor :window requestor)) (defun main () (let* ((*display* (open-default-display)) (screen (display-default-screen *display*)) (*window* (create-window :parent (screen-root screen) :x 10 :y 10 :width 200 :height 200 :event-mask (make-event-mask :button-press :property-change)))) (map-window *window*) (display-finish-output *display*) (event-case (*display*) (:button-press (code time) (format t "~&ButtonPress~%") (finish-output) (case code (1 (setf *time* time) (ownselect)) (2 (ask-paste)) (3 (deselect)))) (:client-message () (format t "~&ClientMessage~%") (finish-output)) (:selection-clear (selection) (format t "~&SelectionClear ~S~%" selection) (finish-output)) (:selection-notify (selection target property) (format t "~&SelectionNotify ~S ~S ~S~%" selection target property) (finish-output) (unless (eq property nil) (recv-paste property)) (display-finish-output *display*)) (:selection-request (selection target property requestor time) (format t "~&SelectionRequest ~S ~S ~S~%" selection target property) (finish-output) (send-copy selection target property requestor time) (display-finish-output *display*)) (:property-notify (atom state) (format t "~&PropertyNotify ~S ~S~%" atom state) (finish-output)))))

1 0