small-cl-src

small-cl-src@common-lisp.net

44 discussions

[Small-cl-src] Small, occasionally handy piece of code
by Ingvar 09 Jul '04

09 Jul '04

;;; Haven't we all felt the need of generating combinations from a collection ;;; and calling a function for every combination? ;;; ;;; It's about as easy as this: ;;; <list> is the initial set ;;; <num> is the number of elements in the resulting combination ;;; <func> is the callback function (defun call-with-combination (list num func &optional acc) (declare (list list acc) (fixnum num) (function func)) (if (zerop num) (apply func acc) (loop for elt in list do (call-with-combination (remove elt list) (1- num) func (cons elt acc)))))

2 2

[Small-cl-src] Useless piece of code, with Important Information in comments
by Ingvar 09 Jul '04

09 Jul '04

;;; No More Mr Nice Listadmin... ;;; Remember, small-cl-src is "source code only" and "plain text". ;;; ALL comments on code SHOULD be sent to small-cl-src-discuss(a)hexapodia.net ;;; Attachments MUST NOT be used when mailing small-cl-src ;;; In theory, in a unix environment, with an mh-style mailfile ;;; the following should result in a loadable lisp file (when called with the ;;; file name of the mh-style mail file and a suitable output stream): (defun extract-small-cl-source (filename &optional (outstream t)) (let ((extract nil)) (with-open-file (infile filename) (do ((line (read-line infile nil infile) (read-line infile nil infile))) ((or (eq line infile) (string= line "_______________________________________________") (string= line "-- ")) nil) (setf extract (or extract (string= line ""))) (when extract (format outstream "~a~%" line))))))

1 0

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

27 Jun '04

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))) (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 .

2 1

[Small-cl-src] Computed features expressions
by Helmut Eller 26 Jun '04

26 Jun '04

;; Here's a little trick I just discovered. Dunno how portable it is. ;; ;; I often would like to write code like: ;; ;; (if <complicated-test> ;; (defun foo () <version1>) ;; (defun foo () <version2>)) ;; ;; The drawback of this idiom is that FOO is no longer at toplevel. ;; If we write ;; ;; #+<complicated-test> ;; (defun foo () <version1>) ;; #-<complicated-test> ;; (defun foo () <version2>) ;; ;; FOO would be at toplevel, but <complicated-test> can only contain ;; simple feature expressions. ;; ;; But if we write ;; ;; #+#.(if <complicated-test> '(and) '(or)) ;; (defun foo () <version1>) ;; #-#.(if <complicated-test> '(and) '(or)) ;; (defun foo () <version2>) ;; ;; we get the advantages of both variants. ;; Define ASSQ unless it is already defined: #+#.(cl:if (cl:fboundp 'cl-user::assq) '(or) '(and)) (defun assq (item list) (assoc item list :test #'eq))

1 0

[Small-cl-src] shuffle-vector
by Ben Hyde 24 Jun '04

24 Jun '04

(defun shuffle-vector (v) "Return copy of vector with elements shuffled like a deck of cards." (loop with result = (copy-seq v) finally (return result) for i from (length v) downto 1 as j = (random i) do (rotatef (svref result j) (svref result (1- i))))) That was fun.

2 1

[Small-cl-src] Abusing shift operations for fun and profit...
by Ingvar 24 Jun '04

24 Jun '04

;;; This is a creative abuse of symbol-macros ;;; Inspired by the question: ;;; How do you do: ;;; stdout << "Hi" << endl; ;;; in lisp? (defpackage "EVILHACK" (:use "CL")) (in-package "EVILHACK") (defclass c++-stream () ((thestream :reader thestream :initarg :thestream))) (defmethod (setf thestream) (new-value (obj c++-stream)) (print new-value (thestream obj)) obj) (defmacro with-c++-semantics ((streamvar stream) &body body) (let ((cpstream (gensym))) `(let ((,cpstream (make-instance 'c++-stream :thestream ,stream))) (symbol-macrolet ((,streamvar (thestream ,cpstream))) ,@body)))) (with-c++-semantics (stdout *standard-output*) (shiftf stdout "Hello World!"))

1 0

[Small-cl-src] a CLIM frontend to RT, the regression tester
by Andreas Fuchs 15 Jun '04

15 Jun '04

Hi, This is a first shot at a regression tester in CLIM. I don't know if the style is squeaky clean (forcing redisplay of panes to re-run the tests seems a bit suboptimal). Still, it's my first real clim program. (-: Have fun, -- Andreas Fuchs, <asf(a)boinkor.net>, asf(a)jabber.at, antifuchs

1 0

[Small-cl-src] macroexpand-most
by Lars Brinkhoff 10 Jun '04

10 Jun '04

;;; A function that expands most macros in a form and its subforms. ;;; It doesn't expand symbol macros or macros implemented as special ;;; operators. ;;; Exercises: ;;; 1. (easy) What's the problem with symbol macros? ;;; 2. (hard) Add support for symbol macros. (defvar *substitutions*) (defun make-hook (old-hook) (lambda (fn form env) (let ((expansion (funcall old-hook fn form env))) (unless (symbolp form) (push (cons expansion form) *substitutions*)) expansion))) (defun macroexpand-most (form) (let ((*substitutions* nil) (*error-output* (make-broadcast-stream)) (*macroexpand-hook* (make-hook *macroexpand-hook*))) (setq form (copy-tree form)) (compile nil `(lambda () ,form)) (dolist (s (nreverse *substitutions*) form) (setq form (nsubst (car s) (cdr s) form :test #'eq))))) (eval-when (:execute) (mapc #'compile '(make-hook macroexpand-most)))

1 0

[Small-cl-src] Locatives
by Lars Brinkhoff 07 Jun '04

07 Jun '04

;;; A portable implementation of locatives (or first-class places). ;;; From the Lisp Machine Manual: ;;; ;;; A locative is a type of Lisp object used as a pointer to a cell. ;;; [...] A cell is a machine word that can hold a (pointer to a) Lisp ;;; object. For example, a symbol has five cells: the print name cell, ;;; the value cell, the function cell, the property list cell, and the ;;; package cell. The value cell holds (a pointer to) the binding of ;;; the symbol, and so on. [...] A locative is an object that points ;;; to a cell: it lets you refer to a cell so that you can examine or ;;; alter its contents. ;;; ;;; Since standard Common Lisp doesn't provide any way to create a pointer ;;; to a cell, this implementation instead uses the setf place machinery. ;;; This makes locatives more versatile, as they can refer to not just a ;;; cell, but any place, e.g. a single bit or multiple values. Because of ;;; this, a locative can't be an immediate value like a machine address, so ;;; it also makes locatives more heavy-weight. In this implementation, ;;; creating a locative involves consing two closures, plus storage to hold ;;; them. ;;; Two additional Lisp machine locative operators, location-boundp and ;;; location-makunbound, can at best only be approximated, so are better ;;; left out completely. ;;; Usage example: ;;; ;;; (defun foo (list) ;;; ;; Return a locative pointing into a list. ;;; (locf (nth 2 list))) ;;; ;;; (defun bar (array) ;;; ;; Return a locative pointing into an array. ;;; (locf (aref array 3))) ;;; ;;; (defun frob (loc) ;;; ;; Modify the contents of the place. ;;; (setf (contents loc) 42)) ;;; ;;; (let ((list (list 1 2 3 4 5)) ;;; (array (vector 1 2 3 4 5))) ;;; (frob (foo list)) ;;; (frob (bar array)) ;;; (values list array)) (defpackage #:locatives (:use #:common-lisp) (:export #:locative #:locativep #:locf #:contents)) (in-package #:locatives) (eval-when (:compile-toplevel :execute) (defconstant +locative-doc+ "A locative is a type of Lisp object used as a pointer to a place.") (defconstant +locativep-doc+ "Returns true if the object is a locative.")) ;;; Three different storage types for locatives are provided: ;;; structure, class, or cons. #+(and) (progn (defstruct (locative (:predicate locativep) (:constructor make-locative (reader writer)) (:copier nil)) #.+locative-doc+ (reader nil :type function :read-only t) (writer nil :type function :read-only t)) (setf (documentation 'locativep 'function) #.+locativep-doc+)) #+(or) (progn (defclass locative () ((reader :initarg :reader :type function :reader locative-reader) (writer :initarg :writer :type function :reader locative-writer)) (:documentation #.+locative-doc+)) (defun locativep (object) #.+locativep-doc+ (typep object 'locative)) (defun make-locative (reader writer) (make-instance 'locative :reader reader :writer writer))) #+(or) (progn (deftype locative () #.+locative-doc+ `(cons function function)) (defun locativep (object) #.+locativep-doc+ (typep object 'locative)) (defun locative-reader (loc) (car loc)) (defun locative-writer (loc) (cdr loc)) (defun make-locative (reader writer) (cons reader writer))) (when (find-class 'locative nil) (defmethod print-object ((object locative) stream) (print-unreadable-object (object stream :type t :identity t)) object)) (defmacro locf (place &environment env) "Return a locative for place." (multiple-value-bind (temps values variables writer reader) (get-setf-expansion place env) `(let* ,(mapcar #'list temps values) (make-locative (lambda () ,reader) (lambda ,variables ,writer))))) (defun contents (locative) "Returns the contents of the place which the locative points to." (funcall (locative-reader locative))) (define-setf-expander contents (locative &environment env) "Modifies the contents of the place which the locative points to." (multiple-value-bind (temps values variables writer reader) (get-setf-expansion locative env) (declare (ignore writer)) (values temps values variables `(funcall (locative-writer ,reader) ,@variables) `(funcall (locative-reader ,reader)))))

1 0

[Small-cl-src] apply in terms of funcall
by Andreas Fuchs 06 Jun '04

06 Jun '04

;;; A few months ago, there was a thread about FUNCALL and APPLY on ;;; c.l.l. I wrote this code to show how APPLY might be defined in ;;; terms of FUNCALL. (defun apply-definer (max-args) `(defun my-apply (f &rest args) (case (length args) ,@(loop for arg-count from 0 to max-args collect `((,arg-count) (funcall f ,@(loop for arg-idx from 0 to (1- arg-count) collect `(nth ,arg-idx args))))) (otherwise (error ,(format nil "Can't apply to more than ~A args" max-args)))))) (defmacro define-apply (max-args) (apply-definer (etypecase max-args (symbol (symbol-value max-args)) (number max-args)))) (apply-definer call-arguments-limit) ;;; License: BSD-sans-advertising. -- Andreas Fuchs, <asf(a)boinkor.net>, asf(a)jabber.at, antifuchs

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