Permalink
Browse files

further staging

  • Loading branch information...
1 parent 1ccc065 commit a64fdaed3dd1d2d2bd62db71d64d6bf3c80b5d34 @lisp committed Feb 23, 2010
Showing with 13,057 additions and 0 deletions.
  1. +661 −0 agpl.txt
  2. +2 −0 base/.svn/README.txt
  3. 0 base/.svn/empty-file
  4. +50 −0 base/.svn/entries
  5. +1 −0 base/.svn/format
  6. 0 base/.svn/prop-base/clos.lisp.svn-base
  7. 0 base/.svn/prop-base/definitions.lisp.svn-base
  8. 0 base/.svn/prop-base/mach-o-traps.lisp.svn-base
  9. 0 base/.svn/prop-base/utilities.lisp.svn-base
  10. 0 base/.svn/props/clos.lisp.svn-work
  11. 0 base/.svn/props/definitions.lisp.svn-work
  12. 0 base/.svn/props/mach-o-traps.lisp.svn-work
  13. 0 base/.svn/props/utilities.lisp.svn-work
  14. +111 −0 base/.svn/text-base/clos.lisp.svn-base
  15. +249 −0 base/.svn/text-base/definitions.lisp.svn-base
  16. +1,053 −0 base/.svn/text-base/mach-o-traps.lisp.svn-base
  17. +91 −0 base/.svn/text-base/utilities.lisp.svn-base
  18. +1,057 −0 base/mach-o-traps.lisp
  19. +391 −0 base/package.lisp
  20. +56 −0 base/parameters.lisp
  21. +112 −0 base/utilities.lisp
  22. +2 −0 geometry/.svn/README.txt
  23. 0 geometry/.svn/empty-file
  24. +70 −0 geometry/.svn/entries
  25. +1 −0 geometry/.svn/format
  26. 0 geometry/.svn/prop-base/lisp-serializer.lisp.svn-base
  27. 0 geometry/.svn/prop-base/location-math.lisp.svn-base
  28. 0 geometry/.svn/prop-base/location-transform.lisp.svn-base
  29. 0 geometry/.svn/prop-base/locations.lisp.svn-base
  30. 0 geometry/.svn/prop-base/matrix.lisp.svn-base
  31. 0 geometry/.svn/prop-base/transform-context.lisp.svn-base
  32. 0 geometry/.svn/props/lisp-serializer.lisp.svn-work
  33. 0 geometry/.svn/props/location-math.lisp.svn-work
  34. 0 geometry/.svn/props/location-transform.lisp.svn-work
  35. 0 geometry/.svn/props/locations.lisp.svn-work
  36. 0 geometry/.svn/props/matrix.lisp.svn-work
  37. 0 geometry/.svn/props/transform-context.lisp.svn-work
  38. +39 −0 geometry/.svn/text-base/lisp-serializer.lisp.svn-base
  39. +596 −0 geometry/.svn/text-base/location-math.lisp.svn-base
  40. +710 −0 geometry/.svn/text-base/location-transform.lisp.svn-base
  41. +2,253 −0 geometry/.svn/text-base/locations.lisp.svn-base
  42. +746 −0 geometry/.svn/text-base/matrix.lisp.svn-base
  43. +143 −0 geometry/.svn/text-base/transform-context.lisp.svn-base
  44. +579 −0 geometry/location-math.lisp
  45. +716 −0 geometry/location-transform.lisp
  46. +2,321 −0 geometry/locations.lisp
  47. +750 −0 geometry/matrix.lisp
  48. +146 −0 geometry/transform-context.lisp
  49. +151 −0 graphics.asd
View
Oops, something went wrong.
@@ -0,0 +1,2 @@
+This is a Subversion working copy administrative directory.
+Visit http://subversion.tigris.org/ for more information.
No changes.
View
@@ -0,0 +1,50 @@
+<?xml version="1.0" encoding="utf-8"?>
+<wc-entries
+ xmlns="svn:">
+<entry
+ committed-rev="1"
+ name=""
+ committed-date="2006-08-09T18:47:39.806190Z"
+ url="file:///Volumes/yoda-ext-fw/Development/Source/Repository/svnroot/dev/Library/trunk/de/setf/object-graphics/code/base"
+ last-author="janson"
+ kind="dir"
+ uuid="5c69cada-db8f-48ca-8610-988f9f4d2d05"
+ repos="file:///Volumes/yoda-ext-fw/Development/Source/Repository/svnroot/dev/Library"
+ revision="1"/>
+<entry
+ committed-rev="1"
+ name="definitions.lisp"
+ text-time="2006-08-09T21:18:02.000000Z"
+ committed-date="2006-08-09T18:47:39.806190Z"
+ checksum="62a0f661f2ca5d3e31fa079ad5d998a3"
+ last-author="janson"
+ kind="file"
+ prop-time="2006-08-09T21:18:02.000000Z"/>
+<entry
+ committed-rev="1"
+ name="mach-o-traps.lisp"
+ text-time="2006-08-09T21:18:02.000000Z"
+ committed-date="2006-08-09T18:47:39.806190Z"
+ checksum="bc4850a325ad397452230c5a97c636e5"
+ last-author="janson"
+ kind="file"
+ prop-time="2006-08-09T21:18:02.000000Z"/>
+<entry
+ committed-rev="1"
+ name="utilities.lisp"
+ text-time="2006-08-09T21:18:02.000000Z"
+ committed-date="2006-08-09T18:47:39.806190Z"
+ checksum="7e89c5dc2d3672cd50a35a934e8b70d2"
+ last-author="janson"
+ kind="file"
+ prop-time="2006-08-09T21:18:02.000000Z"/>
+<entry
+ committed-rev="1"
+ name="clos.lisp"
+ text-time="2006-08-09T21:18:02.000000Z"
+ committed-date="2006-08-09T18:47:39.806190Z"
+ checksum="04a727a9f6d62826ad92391e124b9a8a"
+ last-author="janson"
+ kind="file"
+ prop-time="2006-08-09T21:18:02.000000Z"/>
+</wc-entries>
View
@@ -0,0 +1 @@
+4
No changes.
@@ -0,0 +1,111 @@
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*-
+
+(in-package :de.setf.utility.implementation)
+
+(modPackage :setf.clos
+ (:export
+ :denominated-progn
+ ))
+
+(define-method-combination denominated-progn (&key (operator 'progn)
+ (qualifiers nil)
+ (order :most-specific-first)
+ (call-next-method-p t)
+ (if-not-applicable nil)
+ (verbose-p nil))
+ ((after (:after) :order :most-specific-last)
+ (around (:around) :order :most-specific-first)
+ (before (:before) :order :most-specific-first)
+ (between (:between) :order :most-specific-first)
+ (all-methods * :required t :order :most-specific-last))
+ (:generic-function function)
+ "combine all qualified methods. no unqualified method is permitted. the method qualifiers are arbitrary. the initial set of applicable methods, as sorted according to the combination's :order specification, is grouped by qualifier. the qualifier groups are then arranged as specified by the applicable qualifiers for the given function and arguments.
+ for a given generic function definition, the qualifiers may be a literal list, or it may be a function designator. in the latter cases, the function is applied to a list* of the generic function and the specializers."
+ (ecase if-not-applicable ((nil)) (:error))
+ (ecase order (:most-specific-first ) (:most-specific-last ))
+ (flet ((eliminate (these from)
+ "in case * matches everything, nut just those unmatched by others"
+ (dolist (this these) (setf from (remove this from)))
+ from))
+ (let ((primary (eliminate after (eliminate around (eliminate before (eliminate between all-methods)))))
+ (grouped-methods nil)
+ (group nil)
+ (applicable-qualifiers nil)
+ (method-qualifiers nil)
+ (qualifier nil)
+ (form nil)
+ (first-group-p t))
+ (unless primary
+ (method-combination-error "no applicable primary methods for ~s." function))
+ (when verbose-p
+ (format t "~%:around: ~s~%:before: ~s~%primary: ~s~%:after: ~s" around before primary after))
+
+ ;; collect the qualifier constraints for the given arguments and function
+ ;; these are either a literal list, or generated for the specializers
+ (setf applicable-qualifiers (etypecase qualifiers
+ (cons
+ qualifiers)
+ ((or (and symbol (not null)) function)
+ (apply qualifiers function (method-specializers (first (last all-methods)))))))
+ (when verbose-p
+ (format t "~%applicable qualifiers: ~s." applicable-qualifiers))
+
+ ;; group the methods by applicable qualifier, result is least-specific-first within arbitrary specializer order
+ ;; i considered allowing multiples when call-next-method-p was false, but there is no clear way to
+ ;; handle multiples which are then superseded.
+ (dolist (method primary)
+ (setf method-qualifiers (method-qualifiers method))
+ (cond ((= 1 (length method-qualifiers))
+ (setf qualifier (first method-qualifiers))
+ (if (or (member qualifier applicable-qualifiers) (find t applicable-qualifiers))
+ (cond ((setf group (assoc qualifier grouped-methods))
+ (push method (rest group)))
+ (t
+ (push (list qualifier method) grouped-methods)))
+ (when if-not-applicable
+ (invalid-method-error method "method qualifier not among those permitted: ~s." applicable-qualifiers))))
+ (t
+ (invalid-method-error method "method must have exactly one qualifier when call-next-method is allowed."))))
+
+ ;; reverse groups if desired to get t groups back in most-specific-last order
+ (when (eq order :most-specific-last)
+ (setf grouped-methods (reverse grouped-methods)))
+ ;; sort the groups by applicable qualifier
+ (setf grouped-methods (stable-sort grouped-methods #'<
+ :key #'(lambda (group) (or (position (first group) applicable-qualifiers)
+ (position t applicable-qualifiers)
+ (break "no position: ~s: ~s." qualifier applicable-qualifiers)))))
+ (when verbose-p
+ (format t "~%grouped ~:w" grouped-methods))
+
+ (flet ((call-method-group (method-group &aux call)
+ (destructuring-bind (qualifier . methods) method-group
+ ;; reverse them if desired to get the most specific methods within each group last
+ (declare (ignore qualifier))
+ (when (eq order :most-specific-last) (setf methods (reverse methods)))
+ (setf call `(call-method ,(first methods) ,(rest methods)))
+ (if first-group-p
+ (setf first-group-p nil)
+ (when between
+ (setf call `(progn (call-method ,(first between) ,(when call-next-method-p (rest between)))
+ ,call))))
+ call))
+ (call-methods (methods)
+ (mapcar #'(lambda (method) `(call-method ,method)) methods)))
+ (setf form
+ (if (rest grouped-methods)
+ ;; if there is more than one group, combine them with the operator.
+ `(,operator ,@(mapcar #'call-method-group grouped-methods))
+ (call-method-group (first grouped-methods))))
+ (when before (setf form `(progn ,@(call-methods before) ,form)))
+ (when after (setf form `(multiple-value-prog1 ,form ,@(call-methods after)))))
+
+ (when around
+ (setf form `(call-method ,(first around)
+ (,@(rest around)
+ (make-method ,form)))))
+
+ (when verbose-p
+ (pprint form))
+
+ form)))
Oops, something went wrong.

0 comments on commit a64fdae

Please sign in to comment.