From tfb at OCF.Berkeley.EDU Fri Jun 4 22:28:39 2004 From: tfb at OCF.Berkeley.EDU (Thomas F. Burdick) Date: Fri, 4 Jun 2004 15:28:39 -0700 Subject: [Small-cl-src] fork, wait, and waitpid for SBCL-0.8.8 Message-ID: <16576.63383.622506.672802@famine.OCF.Berkeley.EDU> --- sb-posix/interface.lisp.~1.13.~ Thu Feb 19 23:47:27 2004 +++ sb-posix/interface.lisp Mon May 10 17:13:46 2004 @@ -112,6 +112,7 @@ ;;; processes, signals (define-call "alarm" int never-fails (seconds unsigned)) +(define-call "fork" sb-posix::pid-t minusp) (define-call "getpgid" sb-posix::pid-t minusp (pid sb-posix::pid-t)) (define-call "getpid" sb-posix::pid-t never-fails) (define-call "getppid" sb-posix::pid-t never-fails) @@ -123,6 +124,36 @@ (define-call "setpgid" int minusp (pid sb-posix::pid-t) (pgid sb-posix::pid-t)) (define-call "setpgrp" int minusp) + +;; FIXME: The status code we get from the wait functions is only +;; useful in combination with the macros that let us examine it. + +(export 'sb-posix::wait :sb-posix) +(declaim (inline sb-posix::wait)) +(defun sb-posix::wait (&optional statusptr) + (declare (type (or null (simple-array (signed-byte 32) (1))) statusptr)) + (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) + (pid (alien-funcall + (extern-alien "wait" (function sb-posix::pid-t (* int))) + (sb-sys:vector-sap ptr)))) + (if (minusp pid) + (syscall-error) + (values pid (aref ptr 0))))) + +(export 'sb-posix::waitpid :sb-posix) +(declaim (inline sb-posix::waitpid)) +(defun sb-posix::waitpid (pid options &optional statusptr) + (declare (type (sb-alien:alien sb-posix::pid-t) pid) + (type (sb-alien:alien int) options) + (type (or null (simple-array (signed-byte 32) (1))) statusptr)) + (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) + (pid (alien-funcall + (extern-alien "waitpid" (function sb-posix::pid-t + sb-posix::pid-t (* int) int)) + pid (sb-sys:vector-sap ptr) options))) + (if (minusp pid) + (syscall-error) + (values pid (aref ptr 0))))) ;;; mmap, msync (define-call "mmap" sb-sys:system-area-pointer From tfb at OCF.Berkeley.EDU Fri Jun 4 22:30:24 2004 From: tfb at OCF.Berkeley.EDU (Thomas F. Burdick) Date: Fri, 4 Jun 2004 15:30:24 -0700 Subject: [Small-cl-src] prefork-example-simple.lisp Message-ID: <16576.63488.239775.846758@famine.OCF.Berkeley.EDU> ;;;; prefork-example-simple.lisp ;;;; ;;;; This is a simple example of writing a preforking Unix server using SBCL. ;;;; This file was written to demonstrate the basic techniques of writing a ;;;; preforking server for educational purposes. For a more nuanced example, ;;;; see prefork-example-realistic.lisp ;;;; ;;;; Because it uses fork(2) and waitpid(2), this file requires a ;;;; patched version of the sb-posix contrib module for SBCL. A patch ;;;; against SBCL-0.8.8 is available separately. ;;;; ;;;; We also assumes a BSD-like system, due to its use of flock(2) for ;;;; serialization. ;;;; 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. (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-posix) (require :sb-bsd-sockets)) (defpackage :prefork-example-simple (:use :cl :sb-bsd-sockets)) (in-package :prefork-example-simple) ;;; In this simple example, the parent sets up a server socket, forks ;;; +NCHILDREN+ child processes, then just sits there, and periodically reaps ;;; and reforks any child processes that die. ;;; ;;; The child processes wait for incoming connections. Not all Unixes serialize ;;; `accept's in the kernel, so we need to handle this ourselves. We do this by ;;; acquiring an exclusive file lock around the call to accept(2). We use ;;; flock(2) to do this, but we could just as well use fcntl(2) or SysV ;;; semaphores. ;;; ;;; The Parent ;;; (defconstant +nchildren+ 8) (defconstant +backlog+ 16) (declaim (type (simple-array (or integer null)) *children*)) (defvar *children* (make-array +nchildren+ :initial-element nil) "the PIDs of our children") (defvar *childp* nil "True in child processes.") (defvar *server-socket* nil) (defvar *lock* nil) (defun start-server () "The main loop of the parent process." (setup) (unwind-protect (progn (fork-children) (loop ;; We call SERVE-EVENT here to let other Lisp applications ;; run, eg, SLIME. (sb-sys:serve-event 60) ;; Periodically reap any dead processes. (reap-children))) (unless *childp* (stop-server)))) (defun stop-server () (kill-children) (teardown-lock) (socket-close *server-socket*)) (defun setup () "Set up sockets and locks so the parent can begin forking." (setup-lock) (setup-parent-signal-handlers) (when *server-socket* (socket-close *server-socket*)) (setf *server-socket* (make-instance 'inet-socket :type :stream :protocol :tcp)) (setf (sockopt-reuse-address *server-socket*) t) (socket-bind *server-socket* (make-inet-address "127.0.0.1") 1978) (socket-listen *server-socket* +backlog+)) ;;; ;;; The child ;;; (defun child-main () "Get in the queue to accept, serve the request, loop." (setup-child-signal-handlers) (loop for socket = (serial-accept *server-socket*) for stream = (socket-make-stream socket :input t :output t) for client-id = (read-line stream) for message = (read stream) do (format stream "Hello ~A, this is PID ~D~%~S" client-id (sb-posix:getpid) message) (finish-output stream) (socket-close socket))) ;;; ;;; Forking and reaping ;;; (defun fork-children () (dotimes (i +nchildren+) (fork-one-child i))) (defun fork-one-child (index) (labels ((child () (unwind-protect (progn (setf *children* (vector) *childp* t) (child-main)) (sb-ext:quit))) (parent (pid) (setf (aref *children* index) pid))) (let ((pid (sb-posix:fork))) (if (zerop pid) (child) (parent pid))))) (defun reap-children () "Unix is sick." (when (every #'null *children*) (return-from reap-children)) (loop for pid = (ignore-errors (sb-posix:waitpid 0 sb-posix::wnohang)) while pid do (let ((index (position pid *children*))) (when index (warn "Reaping child process ~D" pid) (fork-one-child index))))) (defun kill-children () "Unix is sick." (unless *childp* (loop for pid across *children* for index upfrom 0 when pid do (handler-case (sb-posix:kill pid sb-posix::sigterm) (sb-posix:syscall-error (error) (warn "Could not kill PID ~D: ~A" pid error) (setf (aref *children* index) nil)))) (loop for pid across *children* for index upfrom 0 when pid do (ignore-errors (sb-posix:waitpid pid 0)) (setf (aref *children* index) nil)))) ;;; ;;; Signals ;;; (defun setup-child-signal-handlers () (sb-sys:enable-interrupt sb-unix:sigterm (signal-handler 'sb-ext:quit)) (sb-sys:ignore-interrupt sb-unix:sigint)) (defun setup-parent-signal-handlers () (sb-sys:enable-interrupt sb-unix:sigterm (signal-handler 'terminate-gracefully))) (defun terminate-gracefully () (kill-children) (sb-ext:quit)) (defun signal-handler (function) "Return a signal hander function that will funcall FUNCTION." (check-type function (or function symbol)) (lambda (signal code scp) (declare (ignore signal code scp)) (funcall function))) ;;; Locking ;;; ;;; We serialize the child processes access to the server socket by acquiring an ;;; exclusive file lock around the call to accept. The advantage of this is ;;; it's really simple and the kernel takes care of everything for us. The ;;; disadvantage is that the parent process doesn't know what's happening, so it ;;; can't intervene to add or remove child processes. (defmacro with-lock (fd-spec &body forms) (let ((=fd (gensym))) `(let ((,=fd ,fd-spec)) (unwind-protect (progn (flock ,=fd :exclusive) , at forms) (flock ,=fd :unlock))))) (defun serial-accept (socket) (with-lock *lock* (socket-accept socket))) (defun setup-lock () (let ((lock-file (format nil "/tmp/~D.lock" (sb-posix:getpid)))) (unless *lock* (setf *lock* (open lock-file :if-does-not-exist :create))))) (defun teardown-lock () (when *lock* (delete-file *lock*) (close *lock*) (setf *lock* nil))) ;; I didn't patch SB-POSIX to add flock(2) because it isn't POSIX, it's just a ;; convenient BSD function. (defmacro defconstant-once (name form &optional doc) `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,form) ,doc)) (defconstant-once +flock-table+ #((:shared 1) (:exclusive 2) (:nonblocking 4) (:unlock 8))) (defun flock (fd-spec &rest options) "Perform flock(2) on the FD or FILE-STREAM given as FD-SPEC. OPTIONS are taken from +FLOCK-TABLE+" (let* ((options (reduce #'logior options :key (lambda (option) (or (second (find option +flock-table+ :key #'first)) (error "Unknown flock option: ~S" option))) :initial-value 0)) (fd (etypecase fd-spec (sb-alien:int fd-spec) (file-stream (sb-sys:fd-stream-fd fd-spec))))) (sb-alien:alien-funcall (sb-alien:extern-alien "flock" (function sb-alien:int sb-alien:int sb-alien:int)) fd options))) From tfb at OCF.Berkeley.EDU Fri Jun 4 22:33:20 2004 From: tfb at OCF.Berkeley.EDU (Thomas F. Burdick) Date: Fri, 4 Jun 2004 15:33:20 -0700 Subject: [Small-cl-src] prefork-client.lisp Message-ID: <16576.63664.178142.5567@famine.OCF.Berkeley.EDU> ;;;; 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)))) From der_julian at web.de Sat Jun 5 15:53:15 2004 From: der_julian at web.de (Julian Stecklina) Date: Sat, 05 Jun 2004 17:53:15 +0200 Subject: [Small-cl-src] Pattern matching in function headers Message-ID: <86hdtq57dg.fsf@web.de> Hello, I had the idea to do pattern matching in function definitions as Haskell allows. Any comments are welcome. -------------- next part -------------- An embedded and charset-unspecified text was scrubbed... Name: pmatch.lisp URL: -------------- next part -------------- (defpackage :pattern-matching-examples (:nicknames "PMATCH-EXAMPLES") (:use "CL" "PATTERN-MATCHING")) (in-package "PMATCH-EXAMPLES") ;;; Ok, let's do something funky! H?lli, beware! ;; Implement some predicate logic stuff *g* ;; We need some basic predicates (defun binaryp (x) "Checks whether the argument is a binary operator" (funcall (one-of and or) x)) (defun operatorp (x) "Checks whether the argument is an operator" (funcall (one-of and or not) x)) (defun quantorp (x) "Checks whether the argument is a quantor" (funcall (one-of forall exists) x)) ;; Translate an expression into a very simple form with only unary ;; and binary operators (NOT/AND/OR). (defh simplify-expression ;; 'Implies' and 'Equiv'(valence) (implies ?expr1 ?expr2) -> `(or (not ,(simplify-expression expr1)) ,expr2) (equiv ?expr1 ?expr2) -> `(or (and expr1 expr2) (not (or expr1 expr2))) ;; Pass on quantors (?(quantor #'quantorp) ?var ?expr) -> `(,quantor ,var ,(simplify-expression expr)) ;; Pass on unary and binary operators (not ?expr) -> `(not ,(simplify-expression expr)) (?(op #'binaryp) ?expr1 ?expr2) -> `(,op ,(simplify-expression expr1) ,(simplify-expression expr2)) ;; Reduce not-binary operators to binary (?(op #'binaryp) ?expr1 . ?rest) -> `(,op ,expr1 (,op , at rest)) ;; Ignore non-matching ?expr -> expr) ;;; We now assume that every expression consists only of NOT/AND/OR with ;;; atmost two arguments. ;; Perform one praenex transformation step (defh praenex-transform ;; Transform negated quantors (not (forall ?var ?expr)) -> `(exists ,var ,(praenex `(not ,expr))) (not (exists ?var ?expr)) -> `(forall ,var ,(praenex `(not ,expr))) ;; "Lift" a quantor one level (?(op #'binaryp) (?(quantor #'quantorp) ?var ?expr1) ?expr2) -> `(,quantor ,var ,(praenex `(,op ,expr1 ,expr2))) (?(op #'binaryp) ?expr1 (?(quantor #'quantorp) ?var ?expr2)) -> `(,quantor ,var ,(praenex `(,op ,expr1 ,expr2))) ;; Ignore anything else ?expr -> expr) ;; Transform an expression into praenex normal form (defh praenex ;; Transform a negated expression (not ?expr) -> (praenex-transform `(not ,(praenex expr))) ;; Ignore a quantor where it does not hurt (?(quantor #'quantorp) ?var ?expr) -> `(,quantor ,var ,(praenex expr)) ;; Transform (?(op #'binaryp) ?expr1 ?expr2) -> (praenex-transform `(,op ,(praenex expr1) ,(praenex expr2))) ?expr -> expr) ;; Perform one skolem transformation step (defh skolem-transform (forall ?var ?expr) ?subst ?vars -> `(forall ,var ,(skolem-transform expr subst (cons var vars))) (exists ?var ?expr) ?subst ?vars -> (skolem-transform expr (acons var `(,(gentemp "SKOLEM") ,@(reverse vars)) subst) vars) ;; Transform AND/OR/NOT/predicates/functors (?op . ?exprs) ?subst ?vars -> `(,op ,@(loop for expr in exprs collect (skolem-transform expr subst vars))) ?expr ?subst ?vars -> (aif (subst (assoc expr subst)) (cdr subst) expr)) ;; Skolemize an expression in praenex normal form (defh skolem ?expr -> (skolem-transform expr nil nil)) ;; We would transform an arbitrary expression like this: #+ ignore (skolem (praenex (simplify-expression '(implies (and (p 0) (forall x (implies (p x) (p (f x))))) (p (f (f 0))))))) -------------- next part -------------- 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 From asf at boinkor.net Sun Jun 6 21:10:12 2004 From: asf at boinkor.net (Andreas Fuchs) Date: Sun, 06 Jun 2004 23:10:12 +0200 Subject: [Small-cl-src] apply in terms of funcall In-Reply-To: <868yft6hmm.wl%asf@boinkor.net> References: <868yft6hmm.wl%asf@boinkor.net> Message-ID: <86aczg5r63.wl%asf@boinkor.net> On 2004-05-15, Andreas Fuchs wrote: > ;;; 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. ;;; As some of you noted, this version is buggy: it doesn't do the ;;; list-as-last-arg magick correctly. Let's fix that: ;;; This code fixes that: (defun apply-definer (max-args) `(defun apply-1 (f 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)))) (defun my-apply (f &rest args) (let ((last-arg (first (last args)))) (apply-1 f (if (listp last-arg) (append (butlast args) last-arg) args)))) (define-apply ; call-arguments-limit ; might be a bit much for the poor impl 20 ; let's be humane ) ;;; example: #| CL-USER> (defun print-all (&rest args) (loop for arg in args do (print arg))) CL-USER> (my-apply #'print-all 1 2 3 '(1 2 3)) 1 2 3 1 2 3 NIL |# > ;;; License: BSD-sans-advertising. -- Andreas Fuchs, , asf at jabber.at, antifuchs From lars at nocrew.org Mon Jun 7 10:02:35 2004 From: lars at nocrew.org (Lars Brinkhoff) Date: 07 Jun 2004 12:02:35 +0200 Subject: [Small-cl-src] Locatives Message-ID: <85zn7fofd0.fsf@junk.nocrew.org> ;;; 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) , at variables) `(funcall (locative-reader ,reader))))) From lars at nocrew.org Thu Jun 10 09:29:25 2004 From: lars at nocrew.org (Lars Brinkhoff) Date: 10 Jun 2004 11:29:25 +0200 Subject: [Small-cl-src] macroexpand-most Message-ID: <85oenrlq16.fsf@junk.nocrew.org> ;;; 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))) From asf at boinkor.net Tue Jun 15 11:24:22 2004 From: asf at boinkor.net (Andreas Fuchs) Date: Tue, 15 Jun 2004 13:24:22 +0200 Subject: [Small-cl-src] a CLIM frontend to RT, the regression tester Message-ID: <867ju9t66x.wl%asf@boinkor.net> 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. (-: -------------- next part -------------- A non-text attachment was scrubbed... Name: rt-clim.lisp Type: application/octet-stream Size: 7379 bytes Desc: not available URL: -------------- next part -------------- Have fun, -- Andreas Fuchs, , asf at jabber.at, antifuchs From ingvar at cathouse.bofh.se Thu Jun 24 14:50:46 2004 From: ingvar at cathouse.bofh.se (Ingvar) Date: Thu, 24 Jun 2004 15:50:46 +0100 Subject: [Small-cl-src] Abusing shift operations for fun and profit... Message-ID: ;;; 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))) , at body)))) (with-c++-semantics (stdout *standard-output*) (shiftf stdout "Hello World!")) From bhyde at pobox.com Thu Jun 24 15:03:50 2004 From: bhyde at pobox.com (Ben Hyde) Date: Thu, 24 Jun 2004 11:03:50 -0400 Subject: [Small-cl-src] shuffle-vector Message-ID: (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. From gwking at cs.umass.edu Thu Jun 24 15:47:32 2004 From: gwking at cs.umass.edu (Gary King) Date: Thu, 24 Jun 2004 10:47:32 -0500 Subject: [Small-cl-src] shuffle-vector In-Reply-To: References: Message-ID: I like having both destructive and non-destructive versions: (defun shuffle-vector (v) "Return copy of vector with elements shuffled like a deck of cards." (shuffle-vector! (copy-seq v))) (defun shuffle-vector! (result) "Destructively shuffle elements in a vector like a deck of cards." (loop finally (return result) for i from (length result) downto 1 as j = (random i) do (rotatef (svref result j) (svref result (1- i))))) On Jun 24, 2004, at 10:03 AM, Ben Hyde wrote: > > (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. > > > _______________________________________________ > Small-cl-src mailing list > Small-cl-src at hexapodia.net > http://www.hexapodia.net/mailman/listinfo/small-cl-src > > -- Gary Warren King, Lab Manager EKSL East, University of Massachusetts * 413 577 0176 I believe that we can effectively defend ourselves abroad and at home without dimming our principles. Indeed, I believe that our success in defending ourselves depends precisely on not giving up what we stand for. -- Al Gore -------------- next part -------------- A non-text attachment was scrubbed... Name: not available Type: text/enriched Size: 1369 bytes Desc: not available URL: From e9626484 at stud3.tuwien.ac.at Sat Jun 26 18:28:33 2004 From: e9626484 at stud3.tuwien.ac.at (Helmut Eller) Date: Sat, 26 Jun 2004 20:28:33 +0200 Subject: [Small-cl-src] Computed features expressions Message-ID: ;; Here's a little trick I just discovered. Dunno how portable it is. ;; ;; I often would like to write code like: ;; ;; (if ;; (defun foo () ) ;; (defun foo () )) ;; ;; The drawback of this idiom is that FOO is no longer at toplevel. ;; If we write ;; ;; #+ ;; (defun foo () ) ;; #- ;; (defun foo () ) ;; ;; FOO would be at toplevel, but can only contain ;; simple feature expressions. ;; ;; But if we write ;; ;; #+#.(if '(and) '(or)) ;; (defun foo () ) ;; #-#.(if '(and) '(or)) ;; (defun foo () ) ;; ;; 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)) From randall at randallsquared.com Sun Jun 27 04:05:32 2004 From: randall at randallsquared.com (Randall Randall) Date: Sun, 27 Jun 2004 00:05:32 -0400 Subject: [Small-cl-src] simple locking retry Message-ID: <3C24F439-C7EF-11D8-8912-000A95A0F1E8@randallsquared.com> 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 , at body) (unlock ,queue)))) (with-locked-widget (l-id (widget-lock mywidget)) ; do stuff ) -- Randall Randall Property law should use #'EQ , not #'EQUAL . From prunesquallor at comcast.net Sun Jun 27 12:58:34 2004 From: prunesquallor at comcast.net (Joe Marshall) Date: Sun, 27 Jun 2004 08:58:34 -0400 Subject: [Small-cl-src] Re: simple locking retry References: <3C24F439-C7EF-11D8-8912-000A95A0F1E8@randallsquared.com> Message-ID: Randall Randall 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. -- ~jrm