diff --git a/lispbuilder-sdl/trivial-garbage.asd b/lispbuilder-sdl/trivial-garbage.asd deleted file mode 100644 index d89b87d..0000000 --- a/lispbuilder-sdl/trivial-garbage.asd +++ /dev/null @@ -1,36 +0,0 @@ -;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- -;;; -;;; trivial-garbage.asd --- ASDF system definition for trivial-garbage. -;;; -;;; This software is placed in the public domain by Luis Oliveira -;;; and is provided with absolutely no -;;; warranty. - -#-(or cmu scl sbcl allegro clisp openmcl corman lispworks ecl) -(error "Sorry, your Lisp is not supported by trivial-garbage.") - -(defsystem trivial-garbage - :description "Portable finalizers, weak hash-tables and weak pointers." - :author "Luis Oliveira " - :version "0.17" - :licence "Public Domain" - :components ((:module "trivial-garbage" - :components - ((:file "trivial-garbage"))))) - -(defmethod perform ((op test-op) (sys (eql (find-system :trivial-garbage)))) - (operate 'test-op :trivial-garbage-tests)) - -(defsystem trivial-garbage-tests - :description "Unit tests for TRIVIAL-GARBAGE." - :depends-on (trivial-garbage rt) - :components ((:module "trivial-garbage" - :components - ((:file "tests"))))) - -(defmethod perform ((op test-op) - (sys (eql (find-system :trivial-garbage-tests)))) - (operate 'load-op :trivial-garbage-tests) - (funcall (find-symbol (string '#:do-tests) '#:rtest))) - -;; vim: ft=lisp et diff --git a/lispbuilder-sdl/trivial-garbage/README b/lispbuilder-sdl/trivial-garbage/README deleted file mode 100644 index 6ec72b9..0000000 --- a/lispbuilder-sdl/trivial-garbage/README +++ /dev/null @@ -1,26 +0,0 @@ -trivial-garbage is a simple library that provides a portable API to -finalizers, weak hash-tables and weak pointers. - -It is placed in the public domain with absolutely no warranty. - -The various bits of funcionality (finalizers, weak pointers, etc...) -are mutually independent. Feel free to copy whatever bits you find -useful into your own program. - -Documentation is generated with the code below and is available at -. - -(asdf:oos 'asdf:load-op :trivial-garbage) -(require :sb-introspect) - -(let ((syms nil)) - (do-external-symbols (sym :trivial-garbage) - (push sym syms)) - (flet ((snd (sym) (string-downcase (symbol-name sym)))) - (setq syms (sort syms #'string< :key #'snd)) - (dolist (sym syms) - (format t "

— Function: tg:~A" (snd sym)) - (format t "~{ ~A~}

~%" - (mapcar #'snd (sb-introspect:function-arglist sym))) - (format t "

~A

~%~%" - (documentation sym 'function)))))) diff --git a/lispbuilder-sdl/trivial-garbage/release.sh b/lispbuilder-sdl/trivial-garbage/release.sh deleted file mode 100644 index e58987d..0000000 --- a/lispbuilder-sdl/trivial-garbage/release.sh +++ /dev/null @@ -1,147 +0,0 @@ -#!/bin/bash - -### Configuration - -PROJECT_NAME='trivial-garbage' -ASDF_FILE="$PROJECT_NAME.asd" -HOST="common-lisp.net" -RELEASE_DIR="public_html/tarballs/$PROJECT_NAME" -VERSION_FILE="" -#VERSION_FILE="VERSION" -#VERSION_FILE_DIR="/project/$PROJECT_NAME/public_html" - -set -e - -### Process options - -FORCE=0 -VERSION="" - -while [ $# -gt 0 ]; do - case "$1" in - -h|--help) - echo "No help, sorry. Read the source." - exit 0 - ;; - -f|--force) - FORCE=1 - shift - ;; - -v|--version) - VERSION="$2" - shift 2 - ;; - *) - echo "Unrecognized argument '$1'" - exit 1 - ;; - esac -done - -### Check for unrecorded changes - -if darcs whatsnew; then - echo -n "Unrecorded changes. " - if [ "$FORCE" -ne 1 ]; then - echo "Aborting." - echo "Use -f or --force if you want to make a release anyway." - exit 1 - else - echo "Continuing anyway." - fi -fi - -### Determine new version number - -if [ -z "$VERSION" ]; then - CURRENT_VERSION=$(grep :version $ASDF_FILE | cut -d\" -f2) - - dots=$(echo "$CURRENT_VERSION" | tr -cd '.') - count=$(expr length "$dots" + 1) - declare -a versions - - for i in $(seq $count); do - new="" - for j in $(seq $(expr $i - 1)); do - p=$(echo "$CURRENT_VERSION" | cut -d. -f$j) - new="$new$p." - done - part=$(expr 1 + $(echo "$CURRENT_VERSION" | cut -d. -f$i)) - new="$new$part" - for j in $(seq $(expr $i + 1) $count); do new="$new.0"; done - versions[$i]=$new - done - - while true; do - echo "Current version is $CURRENT_VERSION. Which will be next one?" - for i in $(seq $count); do echo " $i) ${versions[$i]}"; done - echo -n "? " - read choice - - if ((choice > 0)) && ((choice <= ${#versions[@]})); then - VERSION=${versions[$choice]} - break - fi - done -fi - -### Do it - -TARBALL_NAME="${PROJECT_NAME}_${VERSION}" -TARBALL="$TARBALL_NAME.tar.gz" -SIGNATURE="$TARBALL.asc" - -echo "Updating $ASDF_FILE with new version: $VERSION" -sed -e "s/:version \"$CURRENT_VERSION\"/:version \"$VERSION\"/" \ - "$ASDF_FILE" > "$ASDF_FILE.tmp" -mv "$ASDF_FILE.tmp" "$ASDF_FILE" - -darcs record -m "update $ASDF_FILE for version $VERSION" - -echo "Tagging the tree..." -darcs tag "$VERSION" - -echo "Creating distribution..." -darcs dist -d "$TARBALL_NAME" - -echo "Signing tarball..." -gpg -b -a "$TARBALL" - -echo "Copying tarball to web server..." -scp "$TARBALL" "$SIGNATURE" "$HOST:$RELEASE_DIR" -echo "Uploaded $TARBALL and $SIGNATURE." - -echo "Updating ${PROJECT_NAME}_latest links..." -ssh $HOST ln -sf "$TARBALL" "$RELEASE_DIR/${PROJECT_NAME}_latest.tar.gz" -ssh $HOST ln -sf "$SIGNATURE" "$RELEASE_DIR/${PROJECT_NAME}_latest.tar.gz.asc" - -if [ "$VERSION_FILE" ]; then - echo "Uploading $VERSION_FILE..." - echo -n "$VERSION" > "$VERSION_FILE" - scp "$VERSION_FILE" "$HOST":"$VERSION_FILE_DIR" - rm "$VERSION_FILE" -fi - -while true; do - echo -n "Clean local tarball and signature? [y] " - read -n 1 response - case "$response" in - y|'') - echo - rm "$TARBALL" "$SIGNATURE" - break - ;; - n) - break - ;; - *) - echo "Invalid response '$response'. Try again." - ;; - esac -done - -echo "Building and uploading documentation..." -make -C doc upload-docs - -echo "Pushing changes..." -darcs push diff --git a/lispbuilder-sdl/trivial-garbage/tests.lisp b/lispbuilder-sdl/trivial-garbage/tests.lisp deleted file mode 100644 index 2c054d2..0000000 --- a/lispbuilder-sdl/trivial-garbage/tests.lisp +++ /dev/null @@ -1,115 +0,0 @@ -;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- -;;; -;;; tests.lisp --- trivial-garbage tests. -;;; -;;; This software is placed in the public domain by Luis Oliveira -;;; and is provided with absolutely no -;;; warranty. - -(defpackage #:trivial-garbage-tests - (:use #:cl #:trivial-garbage #:regression-test) - (:nicknames #:tg-tests)) - -(in-package #:trivial-garbage-tests) - -;;;; Weak Pointers - -(deftest pointers.1 - (weak-pointer-p (make-weak-pointer 42)) - t) - -(deftest pointers.2 - (weak-pointer-value (make-weak-pointer 42)) - 42) - -;;;; Weak Hashtables - -#+(or sbcl corman scl) -(progn - (pushnew 'hashtables.weak-key.1 rt::*expected-failures*) - (pushnew 'hashtables.weak-key.2 rt::*expected-failures*)) - -(deftest hashtables.weak-key.1 - (let ((ht (make-weak-hash-table :weakness :key))) - (values (hash-table-p ht) - (hash-table-weakness ht))) - t :key) - -(deftest hashtables.weak-key.2 - (let ((ht (make-weak-hash-table :weakness :key :test 'eq))) - (values (hash-table-p ht) - (hash-table-weakness ht))) - t :key) - -#+(or sbcl cmu corman scl) -(pushnew 'hashtables.weak-value.1 rt::*expected-failures*) - -(deftest hashtables.weak-value.1 - (let ((ht (make-weak-hash-table :weakness :value))) - (values (hash-table-p ht) - (hash-table-weakness ht))) - t :value) - -(deftest hashtables.not-weak.1 - (hash-table-weakness (make-hash-table)) - nil) - -;;;; Finalizers -;;; -;;; These tests are, of course, not very reliable. - -(defun dummy (x) - (declare (ignore x)) - nil) - -(defun test-finalizers-aux (count extra-action) - (let ((cons (list 0)) - (obj (string (gensym)))) - (dotimes (i count) - (finalize obj (lambda () (incf (car cons))))) - (when extra-action - (cancel-finalization obj) - (when (eq extra-action :add-again) - (dotimes (i count) - (finalize obj (lambda () (incf (car cons))))))) - (setq obj (gensym)) - (setq obj (dummy obj)) - cons)) - -(defvar *result*) - -;;; I don't really understand this, but it seems to work, and stems -;;; from the observation that typing the code in sequence at the REPL -;;; achieves the desired result. Superstition at its best. -(defmacro voodoo (string) - `(funcall - (compile nil `(lambda () - (eval (let ((*package* (find-package :tg-tests))) - (read-from-string ,,string))))))) - -(defun test-finalizers (count &optional remove) - (gc :full t) - (voodoo (format nil "(setq *result* (test-finalizers-aux ~S ~S))" - count remove)) - (voodoo "(gc :full t)") - (voodoo "(car *result*)")) - -(deftest finalizers.1 - (test-finalizers 1) - 1) - -(deftest finalizers.2 - (test-finalizers 1 t) - 0) - -(deftest finalizers.3 - (test-finalizers 5) - 5) - -(deftest finalizers.4 - (test-finalizers 5 t) - 0) - -(deftest finalizers.5 - (test-finalizers 5 :add-again) - 5) diff --git a/lispbuilder-sdl/trivial-garbage/trivial-garbage.lisp b/lispbuilder-sdl/trivial-garbage/trivial-garbage.lisp deleted file mode 100644 index 0263310..0000000 --- a/lispbuilder-sdl/trivial-garbage/trivial-garbage.lisp +++ /dev/null @@ -1,301 +0,0 @@ -;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- -;;; -;;; trivial-garbage.lisp --- Trivial Garbage! -;;; -;;; This software is placed in the public domain by Luis Oliveira -;;; and is provided with absolutely no -;;; warranty. - -(defpackage #:trivial-garbage - (:use #:cl) - (:shadow #:make-hash-table) - (:nicknames #:tg) - (:export #:gc - #:make-weak-pointer - #:weak-pointer-value - #:weak-pointer-p - #:make-weak-hash-table - #:hash-table-weakness - #:finalize - #:cancel-finalization)) - -(in-package #:trivial-garbage) - -;;;; GC - -(defun gc (&key full verbose) - "Initiates a garbage collection." - (declare (ignorable verbose full)) - #+(or cmu scl) (ext:gc :verbose verbose :full full) - #+sbcl (sb-ext:gc :full full) - #+allegro (excl:gc (not (null full))) - #+clisp (ext:gc) - #+ecl (si:gc t) - #+openmcl (ccl:gc) - #+corman (ccl:gc (if full 3 0)) - #+lispworks (hcl:mark-and-sweep (if full 3 0))) - -;;;; Weak Pointers - -#+openmcl -(defvar *weak-pointers* (cl:make-hash-table :test 'eq :weak :value) - "Weak value hash-table mapping between pseudo weak pointers and its values.") - -#+(or allegro openmcl lispworks) -(defstruct (weak-pointer (:constructor %make-weak-pointer)) - #-openmcl pointer) - -(defun make-weak-pointer (object) - "Creates a new weak pointer which points to OBJECT. For - portability reasons, OBJECT most not be NIL." - (assert (not (null object))) - #+sbcl (sb-ext:make-weak-pointer object) - #+(or cmu scl) (ext:make-weak-pointer object) - #+clisp (ext:make-weak-pointer object) - #+ecl (error "not implemented") - #+allegro - (let ((wv (excl:weak-vector 1))) - (setf (svref wv 0) object) - (%make-weak-pointer :pointer wv)) - #+openmcl - (let ((wp (%make-weak-pointer))) - (setf (gethash wp *weak-pointers*) object) - wp) - #+corman (ccl:make-weak-pointer object) - #+lispworks - (let ((array (make-array 1))) - (hcl:set-array-weak array t) - (setf (svref array 0) object) - (%make-weak-pointer :pointer array))) - -#-(or allegro openmcl lispworks) -(defun weak-pointer-p (object) - "Returns true if OBJECT is a weak pointer and NIL otherwise." - #+sbcl (sb-ext:weak-pointer-p object) - #+(or cmu scl) (ext:weak-pointer-p object) - #+clisp (ext:weak-pointer-p object) - #+ecl (error "not implemented") - #+corman (ccl:weak-pointer-p object)) - -(defun weak-pointer-value (weak-pointer) - "If WEAK-POINTER is valid, returns its value. Otherwise, returns NIL." - #+sbcl (values (sb-ext:weak-pointer-value weak-pointer)) - #+(or cmu scl) (values (ext:weak-pointer-value weak-pointer)) - #+clisp (values (ext:weak-pointer-value weak-pointer)) - #+ecl (error "not implemented") - #+allegro (svref (weak-pointer-pointer weak-pointer) 0) - #+openmcl (values (gethash weak-pointer *weak-pointers*)) - #+corman (ccl:weak-pointer-obj weak-pointer) - #+lispworks (svref (weak-pointer-pointer weak-pointer) 0)) - -;;;; Weak Hash-tables - -;;; Allegro can apparently create weak hash-tables with both weak keys -;;; and weak values but it's not obvious whether it's an OR or an AND -;;; relation. TODO: figure that out. - -(defun weakness-keyword-arg (weakness) - (declare (ignorable weakness)) - #+sbcl :weakness - #+(or clisp openmcl) :weak - #+lispworks :weak-kind - #+allegro (case weakness (:key :weak-keys) (:value :values)) - #+cmu :weak-p) - -(defun weakness-keyword-opt (weakness) - (ecase weakness - (:key - #+(or lispworks sbcl clisp openmcl) :key - #+(or allegro cmu) t - #-(or lispworks sbcl clisp openmcl allegro cmu) - (error "Your Lisp does not support weak key hash-tables.")) - (:value - #+allegro :weak - #+(or clisp openmcl sbcl lispworks) :value - #-(or allegro clisp openmcl sbcl lispworks) - (error "Your Lisp does not support weak value hash-tables.")) - (:key-or-value - #+(or clisp sbcl) :key-or-value - #+lispworks :either - #-(or clisp sbcl lispworks) - (error "Your Lisp does not support weak key-or-value hash-tables.")) - (:key-and-value - #+(or clisp sbcl) :key-and-value - #+lispworks :both - #-(or clisp sbcl lispworks) - (error "Your Lisp does not support weak key-and-value hash-tables.")))) - -(defun make-weak-hash-table (&rest args &key weakness &allow-other-keys) - "Returns a new weak hash table. In addition to the standard arguments - accepted by CL:MAKE-HASH-TABLE, this function an extra keyword :WEAKNESS - that determines the kind of weak table it should create. WEAKNESS can be - one of :KEY, :VALUE, :KEY-OR-VALUE, :KEY-AND-VALUE. - - TG::MAKE-HASH-TABLE is available as an alias for this function should you - wish to import it into your package and shadow CL:MAKE-HASH-TABLE." - (remf args :weakness) - (if weakness - (apply #'cl:make-hash-table - (weakness-keyword-arg weakness) - (weakness-keyword-opt weakness) - args) - (apply #'cl:make-hash-table args))) - -;;; If you want to use this function to override CL:MAKE-HASH-TABLE, -;;; it's necessary to shadow-import it. For example: -;;; -;;; (defpackage #:foo -;;; (:use #:common-lisp #:trivial-garbage) -;;; (:shadowing-import-from #:trivial-garbage #:make-hash-table)) -;;; -(defun make-hash-table (&rest args) - (apply #'make-weak-hash-table args)) - -(defun hash-table-weakness (ht) - "Returns one of NIL, :KEY, :VALUE, :KEY-OR-VALUE or :KEY-AND-VALUE." - #-(or allegro sbcl clisp cmu openmcl lispworks) - (declare (ignore ht)) - ;; keep this first if any of the other lisps bugously insert a NIL - ;; for the returned (values) even when *read-suppress* is NIL (e.g. clisp) - #.(if (find :sbcl *features*) - (if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT") - (read-from-string "(sb-ext:hash-table-weakness ht)") - nil) - (values)) - #+allegro (cond ((excl:hash-table-weak-keys ht) :key) - ((eq (excl:hash-table-values ht) :weak) :value)) - #+clisp (ext:hash-table-weak-p ht) - #+cmu (if (lisp::hash-table-weak-p ht) :key nil) - #+openmcl (ccl::hash-table-weak-p ht) - #+lispworks (system::hash-table-weak-kind ht)) - -;;;; Finalizers - -;;; The fact that SBCL/CMUCL throw away the object *before* running -;;; the finalizer is somewhat unfortunate... - -;;; Note: Lispworks can't finalize gensyms. - -#+(or allegro clisp lispworks openmcl) -(defvar *finalizers* - (cl:make-hash-table :test 'eq - #+allegro :weak-keys #+:allegro t - #+(or clisp openmcl) :weak - #+lispworks :weak-kind - #+(or clisp openmcl lispworks) :key) - "Weak hashtable that holds registered finalizers.") - -#+corman -(progn - (defvar *finalizers* '() - "Weak alist that holds registered finalizers.") - - (defvar *finalizers-cs* (threads:allocate-critical-section))) - -#+lispworks -(progn - (hcl:add-special-free-action 'free-action) - (defun free-action (object) - (let ((finalizers (gethash object *finalizers*))) - (unless (null finalizers) - (mapc #'funcall finalizers))))) - -(defun finalize (object function) - "Pushes a new FUNCTION to the OBJECT's list of - finalizers. FUNCTION should take no arguments. Returns OBJECT. - - For portability reasons, FUNCTION should not attempt to look - at OBJECT by closing over it because, in some lisps, OBJECT - will already have been garbage collected and is therefore not - accessible when FUNCTION is invoked." - #+(or cmu scl) (ext:finalize object function) - #+sbcl (sb-ext:finalize object function) - #+ecl (let ((next-fn (ext:get-finalizer object))) - (ext:set-finalizer - object (lambda (obj) - (declare (ignore obj)) - (funcall function) - (when next-fn - (funcall next-fn nil))))) - #+allegro - (progn - (push (excl:schedule-finalization - object (lambda (obj) (declare (ignore obj)) (funcall function))) - (gethash object *finalizers*)) - object) - #+clisp - ;; The CLISP code used to be a bit simpler but we had to workaround - ;; a bug regarding the interaction between GC and weak hashtables. - ;; See - ;; and . - (multiple-value-bind (finalizers presentp) - (gethash object *finalizers* (cons 'finalizers nil)) - (unless presentp - (setf (gethash object *finalizers*) finalizers) - (ext:finalize object (lambda (obj) - (declare (ignore obj)) - (mapc #'funcall (cdr finalizers))))) - (push function (cdr finalizers)) - object) - #+openmcl - (progn - (ccl:terminate-when-unreachable - object (lambda (obj) (declare (ignore obj)) (funcall function))) - ;; store number of finalizers - (incf (gethash object *finalizers* 0)) - object) - #+corman - (flet ((get-finalizers (obj) - (assoc obj *finalizers* :test #'eq :key #'ccl:weak-pointer-obj))) - (threads:with-synchronization *finalizers-cs* - (let ((pair (get-finalizers object))) - (if (null pair) - (push (list (ccl:make-weak-pointer object) function) *finalizers*) - (push function (cdr pair))))) - (ccl:register-finalization - object (lambda (obj) - (threads:with-synchronization *finalizers-cs* - (mapc #'funcall (cdr (get-finalizers obj))) - (setq *finalizers* - (delete obj *finalizers* - :test #'eq :key #'ccl:weak-pointer-obj))))) - object) - #+lispworks - (progn - (let ((finalizers (gethash object *finalizers*))) - (unless finalizers - (hcl:flag-special-free-action object)) - (setf (gethash object *finalizers*) - (cons function finalizers))) - object)) - -(defun cancel-finalization (object) - "Cancels all of OBJECT's finalizers, if any." - #+cmu (ext:cancel-finalization object) - #+scl (ext:cancel-finalization object nil) - #+sbcl (sb-ext:cancel-finalization object) - #+ecl (ext:set-finalizer object nil) - #+allegro - (progn - (mapc #'excl:unschedule-finalization - (gethash object *finalizers*)) - (remhash object *finalizers*)) - #+clisp - (multiple-value-bind (finalizers present-p) - (gethash object *finalizers*) - (when present-p - (setf (cdr finalizers) nil)) - (remhash object *finalizers*)) - #+openmcl - (let ((count (gethash object *finalizers*))) - (unless (null count) - (dotimes (i count) - (ccl:cancel-terminate-when-unreachable object)))) - #+corman - (threads:with-synchronization *finalizers-cs* - (setq *finalizers* - (delete object *finalizers* :test #'eq :key #'ccl:weak-pointer-obj))) - #+lispworks - (progn - (remhash object *finalizers*) - (hcl:flag-not-special-free-action object)))