small-cl-src-discuss

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

15 discussions

[Small-cl-src-discuss] Re: [Small-cl-src] defun-with-cache
by Kristian Elof Sørensen 13 Dec '05

13 Dec '05

Hi I played around with your code a bit. There are two compilation errors on sbcl, cmucl and clisp on linux. 1) (finish) does not exist - used when the user supplies &aux 2) *keywork-package* does not exist I changed (finish) into a call to warn I chanhed *keyword-package* into "KEYWORD" which intern the symbol as a keyword With these two changes, it seems that ordinary arguments works but optional does not. Keyword arguments mostly work but there is a problem with the "was this keyword parameters value set it is it its default value" parameter. CL-USER> (defun-cache:defun-with-cache foo (bar baz &optional op0 op1) (list :bar bar :baz baz :op0 op0 :op1 op1)) FOO CL-USER> (defun-cache:defun-with-cache foo1 (bar baz &key op0 (op1 42 op1-set)) (list :bar bar :baz baz :op0 op0 :op1 op1 :op1-set op1-set)) ; ; caught STYLE-WARNING: ; The variable OP1-SET is defined but never used. ; ; compilation unit finished ; caught 1 STYLE-WARNING condition FOO1 CL-USER> (loop for expr in '((foo 1 2 3 4) (foo 4 3 2) (foo 4 3 '(2) '(1)) (foo 1 2) (foo 1) (foo1 1 2 :op1 42) (foo1 1 2 :op0 42) (foo1 1 2 :op1 42 :op0 24)) do (format t "~A " expr) do (catch 'trap-errors (handler-bind ((type-error (lambda (err) (format t "caught type-error: ~A~%" err) (throw 'trap-errors nil))) (error (lambda (err) (format t "caught error: ~A~%" err) (throw 'trap-errors nil)))) (format t "~A no error thrown~%" (eval expr))))) (FOO 1 2 3 4) caught type-error: The value 3 is not of type LIST. (FOO 4 3 2) caught type-error: The value 2 is not of type LIST. (FOO 4 3 '(2) '(1)) (BAR 4 BAZ 3 OP0 (1) OP1 2) no error thrown (FOO 1 2) (BAR 1 BAZ 2 OP0 NIL OP1 NIL) no error thrown (FOO 1) caught error: invalid number of arguments: 1 (FOO1 1 2 OP1 42) (BAR 1 BAZ 2 OP0 NIL OP1 42 OP1-SET T) no error thrown (FOO1 1 2 OP0 42) (BAR 1 BAZ 2 OP0 42 OP1 42 OP1-SET T) no error thrown (FOO1 1 2 OP1 42 OP0 24) (BAR 1 BAZ 2 OP0 24 OP1 42 OP1-SET T) no error thrown NIL The three first expressions shows some problems with optional arguments In the second to last expression the result for (FOO1 1 2 OP0 42) is returning op1-set as t where it should be nil Kristian fre, 09 12 2005 kl. 22:38 -0500, skrev Ben Hyde: > 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))))))))))))) > > _______________________________________________ > Small-cl-src mailing list > Small-cl-src(a)hexapodia.net > http://www.hexapodia.net/mailman/listinfo/small-cl-src

2 4

[Small-cl-src-discuss] Re: small mop compatability layer
by Christophe Rhodes 01 Oct '04

01 Oct '04

marco <mb(a)bese.it> writes: > 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. It surprises me slightly that you think that SLOT-DEFINITION-DOCUMENTATION shouldn't be a generic function. > IMPLEMENTATION - A keyword indetifying the implementation, one > of: :OPENMCL, :SBCL, :CMU, :LISPWORKS. > (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)))) You could be slightly nicer to other implementations by doing ... (unless (provide-mopp-symbol sym (or #+openmcl :openmcl #+sbcl :sbcl #+cmu :cmu #+lispworks :lispworks :unimplemented)) (warn ...)) and either provide a method on :unimplemented or a method on NO-APPLICABLE-METHOD. > (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)))) Unless there's a reason not to, you should be using the "SB-MOP" package here. (If there is a reason, sbcl-devel wants to know about it!) Cheers, Christophe

2 1

[Small-cl-src-discuss] Re: [Small-cl-src] What would var+++ be in CL?
by Douglas Philips 29 Sep '04

29 Sep '04

On Sep 23, 2004, at 11:05 AM, Ingvar wrote: > ;;; 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)))))) Actually, this came up on comp.lang.lisp and a few good versions were posted there. i'm accessing the net via a temp. connection (i'm on vacation), else I'd just search and give the pointer to the posts myself. <D\'gou

2 1

[Small-cl-src-discuss] Re: [Small-cl-src] with-carry
by marco 29 Sep '04

29 Sep '04

Peter Lewerin <peter.lewerin(a)swipnet.se> writes: > #| > 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)) this reminded me of: http://groups.google.com/groups?selm=ahnk8t%247d5%241%40luna.vcn.bc.ca -- -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-discuss] Re: WITH*
by Dirk Gerrits 16 Jul '04

16 Jul '04

Marco Baringer <mb(a)bese.it> writes: > ;;;; Alleviate deep nesting. Suggestions for a better name are welcome. Just a little nit: this seems like an interesting idea in principle, but the example macro call you list is wider than its listed expansion. ;) I don't really have a problem with deep nesting except for its effect on line width, so the example seems unconvincing to me. Regards, Dirk Gerrits

1 0

[Small-cl-src-discuss] Re: packet.lisp, version 2
by Eric Marsden 16 Jul '04

16 Jul '04

Nifty! I played around with this a little, trying to get it to decode packets that I saved using tcpdump's "-w" option. I used the following two functions to read the pcap file. This is throwing away some information that is present in the pcap framing, such as frame number, arrival time, delta since previous packet etc. It also seems to throw away the Ethernet type: reading http://www.hw-server.com/ethernet#link_layer I discovered that there are two Ethernet formats, the old "Ethernet II" format and the IEEE 802.3 format. They aren't quite equivalent, so for Ethernet II packets GRAB-ETHERNET-HEADER is reading what it thinks is the protocol but is in fact LLC data. (defun pcap-file-frames (pathname) (let ((frames (list))) (block reading (with-open-file (raw pathname :direction :input :element-type 'octet) ;; skip over the pcap per-file header (dotimes (i 24) (read-byte raw)) (loop ;; skip over the per-frame header (dotimes (i 12) (unless (read-byte raw nil nil) (return-from reading))) ;; read the frame length (let* ((frame-length (read-uint32 raw)) (frame (make-array frame-length :element-type 'octet))) (read-sequence frame raw) (push frame frames))))) (reverse frames))) (defun decode-pcap-file (pathname) (loop :for frame :in (pcap-file-frames pathname) :collect (decode (coerce frame 'buffer)))) STRUCTURE-SYMBOL-NAMES should be written as follows to avoid problems with *PRINT-CASE*: (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 (concatenate 'string (symbol-name name) "-P")) (find-symbol (concatenate 'string "MAKE-" (symbol-name name))) (structure-accessors name))) Furthermore as I mentioned to Luke on IRC, I think this would benefit from splitting out into multiple files: a README, a package file, a test file, a system-definition file etc. -- Eric Marsden <URL:http://www.laas.fr/~emarsden/>

1 0

[Small-cl-src-discuss] Re: [Small-cl-src] combinations and permutations (was: Small, occasionally handy piece of code)
by Ingvar 09 Jul '04

09 Jul '04

> "Steven E. Harris" <seharris(a)raytheon.com> writes: > > > I wrote one a while ago that may cons less because it requires use > > of vectors to represent the sequences. > > Following up to myself, if you're interested, I also have similar code > to produce permutations from a source vector, though the permutation > algorithm operates destructively in-place on the source sequence. > > It's been about six months since I was doing the analysis for this > code, but I recall some interesting interdependencies between > combinations and permutations. Unfortunately my notes are at home > right now. An interesting variation for generating the Nth permutation of a list L is: (defun excise (number args) (declare (type fixnum number)) (cond ((<= number 0) (cdr args)) (t (cons (car args) (excise (1- number) (cdr args)))))) (defun permute (list num &optional accumulator) (if (null list) (nreverse accumulator) (let* ((length (length list)) (nth (mod num length)) (remainder (rem num length))) (permute (excise nth list) remainder (cons (nth nth list) accumulator))))) * (loop for n from 0 to 5 collect (permute '(1 2 3) n)) ((1 2 3) (2 3 1) (3 1 2) (1 2 3) (2 3 1) (3 1 2)) So far, the only piece of code where I've needed to generate one of all possible permutations for a list has been in a Mandelbrot generator, where I use that for a recursive call to generate smaller and smaller squares on the screen, ignoring to recurse if and only if the sides of the square end up having the same iteration depth before heading for infinity, thus making the whole process somewhat more pleasurable to watch (I *think* that is in the Mandelbrot generator among the SB-CLX demos). //Ingvar

1 0

[Small-cl-src-discuss] combinations and permutations (was: Small, occasionally handy piece of code)
by Steven E. Harris 09 Jul '04

09 Jul '04

[I apologize for posting this article incorrectly first to the "code" list rather than the "discuss" list.] "Steven E. Harris" <seharris(a)raytheon.com> writes: > I wrote one a while ago that may cons less because it requires use > of vectors to represent the sequences. Following up to myself, if you're interested, I also have similar code to produce permutations from a source vector, though the permutation algorithm operates destructively in-place on the source sequence. It's been about six months since I was doing the analysis for this code, but I recall some interesting interdependencies between combinations and permutations. Unfortunately my notes are at home right now. For example, one can compute /how many/ permutations exist for a full draw from a set (n!), or how many permutations exist for a draw k from a set (n!/(n - k)!), but computing how many combinations exist for any draw k is dependent upon the related permutation count (P/k!).¹ However, to actually come up with the /specific/ permutations and combinations, the dependency is reversed. One can come up with combinations in any draw k independently. One can also come up with permutations for a full draw independently. But to come up with the permutations for some draw k, one must first generate the combinations of draw k, then permute each of those combinations as a full draw. The apparent independence of the full draw permutations is due to there being only one combination to permute for a full draw. Footnotes: ¹ http://www.themathpage.com/aPreCalc/permutations-combinations.htm -- Steven E. Harris :: seharris(a)raytheon.com Raytheon :: http://www.raytheon.com

1 0

[Small-cl-src-discuss] Re: [Small-cl-src] Re: simple locking retry
by Randall Randall 27 Jun '04

27 Jun '04

On Jun 27, 2004, at 8:58 AM, Joe Marshall wrote: > Randall Randall <randall(a)randallsquared.com> writes: > >> Second try; let's see if I get it right this time: >> >> This is intended to be a simple locking protocol for >> systems that need to be usable on both serve-event-only >> systems, like CMUCL on PPC, and more ordinary >> multi-processing systems. I'm currently using it as >> part of PSILISP, my webapp framework. >> >> This seems to work, and people I've run it by agree >> that it seems to work, but there could be some serious >> problem with it, so use at your own risk. I am only >> an egg. >> >> This code is released as public domain. >> >> (defmacro enqueue (queue) >> "Appends a unique ID to a queue." >> (let ((id (gensym))) >> `(let ((,id (gensym))) >> (setf ,queue (append ,queue (list ,id))) >> ,id))) > > This isn't thread safe. If two processes attempted to enter the queue > simultaneously, one could get lost. Because the second could run between evaluation of ,queue and evaluation of APPEND? Okay. Is there an atomic way to do that append such that it is thread safe without using specialized machinery not available with serve-event? Alternatively, I guess I could use more #+ expressions. -- Randall Randall <randall(a)randallsquared.com> Property law should use #'EQ , not #'EQUAL .

2 2

[Small-cl-src-discuss] simple locking
by Randall Randall 27 Jun '04

27 Jun '04

This is intended to be a simple locking protocol for systems that need to be usable on both serve-event-only systems, like CMUCL on PPC, and more ordinary multi-processing systems. I'm currently using it as part of PSILISP, my webapp framework. This seems to work, and people I've run it by agree that it seems to work, but there could be some serious problem with it, so use at your own risk. I am only an egg. (defmacro enqueue (queue) "Appends a unique ID to a queue." (let ((id (gensym))) `(let ((,id (gensym))) (setf ,queue (append ,queue (list ,id))) ,id))) (defmacro lock (queue) "Waits in turn in the activity queue until all previous members have exited." (let ((id (gensym))) `(let* ((,id (enqueue ,queue))) #+(and acl-compat (not allegro) (not cmu)) ; CMUCL on PPC doesn't have MP, so we have to use serve-event (ACL-COMPAT.MP:process-wait "waiting for lock" #'eq ,id (car ,queue)) #+allegro (MP:process-wait "waiting for lock" #'eq ,id (car ,queue)) #+cmu (do () ((eq ,id (car ,queue))) (sys:serve-event 0)) ,id))) (defmacro unlock (queue) `(pop ,queue)) Use example, which assumes a WIDGET structure or class, with a MYWIDGET instance, and a WIDGET-LOCK accessor. (defmacro with-locked-widget ((lock-id-var queue) &body body) "Provides a method of locking a widget while in use, if everyone uses this." `(let ((,lock-id-var (lock ,queue))) (unwind-protect (progn ,@body) (unlock ,queue)))) (with-locked-widget (l-id (widget-lock mywidget)) ; do stuff ) -- Randall Randall <randall(a)randallsquared.com> Property law should use #'EQ , not #'EQUAL .

1 1

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

small-cl-src-discuss