Author: junrue Date: Sun Mar 5 18:36:30 2006 New Revision: 28
Added: trunk/src/third-party/ trunk/src/third-party/lw-compat/ trunk/src/third-party/lw-compat/lw-compat-package.lisp trunk/src/third-party/lw-compat/lw-compat.asd trunk/src/third-party/lw-compat/lw-compat.lisp Log: added local copy of lw-compat lib written by Pascal Costanza
Added: trunk/src/third-party/lw-compat/lw-compat-package.lisp ============================================================================== --- (empty file) +++ trunk/src/third-party/lw-compat/lw-compat-package.lisp Sun Mar 5 18:36:30 2006 @@ -0,0 +1,34 @@ +;;;; +;;;; Copyright (c) 2005 Pascal Costanza +;;;; with permission from http://www.lispworks.com +;;;; +;;;; 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) +(in-package #:graphic-forms-system) + +#-lispworks +(defpackage #:lispworks + (:use #:common-lisp) + (:export #:appendf #:nconcf #:rebinding #:removef + #:when-let #:when-let* #:with-unique-names))
Added: trunk/src/third-party/lw-compat/lw-compat.asd ============================================================================== --- (empty file) +++ trunk/src/third-party/lw-compat/lw-compat.asd Sun Mar 5 18:36:30 2006 @@ -0,0 +1,36 @@ +(in-package :cl-user) + +(asdf:defsystem #:lw-compat + :name "LispWorks Compatibility Library" + :author "Pascal Costanza, with permission from http://www.lispworks.com" + :version "0.2" + :licence " +Copyright (c) 2005 Pascal Costanza +with permission from http://www.lispworks.com + +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. +" + :components (#-lispworks + (:file "lw-compat-package") + #-lispworks + (:file "lw-compat" + :depends-on ("lw-compat-package"))))
Added: trunk/src/third-party/lw-compat/lw-compat.lisp ============================================================================== --- (empty file) +++ trunk/src/third-party/lw-compat/lw-compat.lisp Sun Mar 5 18:36:30 2006 @@ -0,0 +1,76 @@ +;;;; +;;;; Copyright (c) 2005 Pascal Costanza +;;;; with permission from http://www.lispworks.com +;;;; +;;;; 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 #:lispworks) + +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (error "lw-compat is not needed in LispWorks.")) + +(define-modify-macro appendf (&rest lists) + append "Appends lists to the end of given list.") + +(define-modify-macro nconcf (&rest lists) + nconc "Appends lists to the end of given list by NCONC.") + +(defmacro rebinding (vars &body body) + "Ensures unique names for all the variables in a groups of forms." + (loop for var in vars + for name = (gensym (symbol-name var)) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names + ,vars + `(let (,,@temps) + ,,@body)))))) + +(define-modify-macro removef (item &rest keys) + (lambda (place item &rest keys &key test test-not start end key) + (declare (ignorable test test-not start end key)) + (apply #'remove item place keys)) + "Removes an item from a sequence.") + +(defmacro when-let ((var form) &body body) + "Executes a body of code if a form evaluates to non-nil, + propagating the result of the form through the body of code." + `(let ((,var ,form)) + (when ,var + (locally + ,@body)))) + +(defmacro when-let* (bindings &body body) + "Executes a body of code if a series of forms evaluates to non-nil, + propagating the results of the forms through the body of code." + (loop for form = `(progn ,@body) then `(when-let (,(car binding) ,(cadr binding)) ,form) + for binding in (reverse bindings) + finally (return form))) + +(defmacro with-unique-names (names &body body) + "Returns a body of code with each specified name bound to a similar name." + `(let ,(mapcar (lambda (name) `(,name (gensym ,(symbol-name name)))) + names) + ,@body))