small-cl-src June 2004

small-cl-src@common-lisp.net

10 participants
12 discussions

[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

[Small-cl-src] Pattern matching in function headers
by Julian Stecklina 05 Jun '04

05 Jun '04

Hello, I had the idea to do pattern matching in function definitions as Haskell allows. Any comments are welcome. Regards, -- Julian Stecklina Signed and encrypted mail welcome. Key-Server: pgp.mit.edu Key-ID: 0xD65B2AB5 FA38 DCD3 00EC 97B8 6DD8 D7CC 35D8 8D0E D65B 2AB5 Any sufficiently complicated C or Fortran program contains an ad hoc informally-specified bug-ridden slow implementation of half of Common Lisp. - Greenspun's Tenth Rule of Programming

1 0

[Small-cl-src] prefork-client.lisp
by Thomas F. Burdick 04 Jun '04

04 Jun '04

;;;; prefork-client.lisp ;;;; ;;;; A very simple SBCL network client for use in testing the servers in ;;;; prefork-example-simple.lisp and prefork-example-realistic.lisp. ;;;; Copyright (C) 2004, 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. (in-package :cl-user) (eval-when (:load-toplevel :compile-toplevel :execute) (require :sb-posix) (require :sb-bsd-sockets) (use-package :sb-bsd-sockets)) ;;; The client is broken across many functions in order to make it easier to ;;; poke at the server. ;;; ;;; We send a line identifying ourselves, then an s-expression. The server ;;; identifies itself, then sends our s-expression back to us. (defvar *socket* nil) (defvar *stream* nil) (defun client (&optional object) "Return the echo from the server as multiple values." (client-connect) (client-herald) (client-write (with-output-to-string (s) (print object s))) (multiple-value-prog1 (client-results) (socket-close *socket*))) ;;; ;;; Easily hang server processes ;;; (defvar *hung* (queue)) (defun hang (&optional (n 1)) "Send N partial requests to the server, causing the processes to hang." (dotimes (i n) (let (*socket* *stream*) (client-connect) (client-herald) (client-write "(:hang ") (queue-add (cons *socket* *stream*) *hung*)))) (defun release (&optional (n 1)) "Send the rest of a proper request to N hung servers." (loop repeat n for pair = (queue-pop *hung*) when pair collect (destructuring-bind (*socket* . *stream*) pair (client-write ":release) ") (client-results)))) ;;; ;;; The guts ;;; (defun client-connect () (setf *socket* (make-instance 'inet-socket :type :stream :protocol :tcp)) (socket-connect *socket* (make-inet-address "127.0.0.1") 1978) (setf *stream* (socket-make-stream *socket* :input t :output t))) (defun client-herald () (format *stream* "PID ~D~%" (sb-posix:getpid)) (finish-output *stream*)) (defun client-write (string) "Send STRING to the server. If this is an incomplete sexp, it can be used to hang the server." (write-string string *stream*) (finish-output *stream*)) (defun client-results () (values (read-line *stream*) (read *stream*))) ;;; ;;; Misc utils ;;; (defstruct (queue (:constructor %make-queue (list tail))) (list nil :type list) (tail nil :type list)) (defun queue (&rest elements) (make-queue elements)) (defun make-queue (&optional list) (%make-queue list (last list))) (defun queue-add (item queue) (if (null (queue-tail queue)) (setf (queue-list queue) (list item) (queue-tail queue) (queue-list queue)) (setf (cdr (queue-tail queue)) (list item) (queue-tail queue) (cdr (queue-tail queue)))) queue) (defun queue-pop (queue) (prog1 (pop (queue-list queue)) (when (null (queue-list queue)) (setf (queue-tail queue) nil))))

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 June 2004