From 56ac2ae4b11ad213f23fcc9a5c33d5e57399b38e Mon Sep 17 00:00:00 2001 From: John Lenz Date: Thu, 7 Apr 2005 00:39:28 +0000 Subject: Add some chicken test-suite entries for overloaded functions (which now work correctly) and update the chicken documentation git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk/SWIG@7146 626c5289-ae23-0410-ae9c-e8d60b6d4f22 --- Lib/chicken/extra-install.list | 2 + Lib/chicken/multi-generic.scm | 150 +++++++++++++++++++++++++++++++ Lib/chicken/tinyclos-multi-generic.patch | 82 +++++++++++++++++ 3 files changed, 234 insertions(+) create mode 100644 Lib/chicken/multi-generic.scm create mode 100644 Lib/chicken/tinyclos-multi-generic.patch (limited to 'Lib/chicken') diff --git a/Lib/chicken/extra-install.list b/Lib/chicken/extra-install.list index 8962be42c..48721cee0 100644 --- a/Lib/chicken/extra-install.list +++ b/Lib/chicken/extra-install.list @@ -1 +1,3 @@ swigclosprefix.scm +multi-generic.scm +tinyclos-multi-generic.patch diff --git a/Lib/chicken/multi-generic.scm b/Lib/chicken/multi-generic.scm new file mode 100644 index 000000000..a1a5c369e --- /dev/null +++ b/Lib/chicken/multi-generic.scm @@ -0,0 +1,150 @@ +;; This file overrides two functions inside TinyCLOS to provide support +;; for multi-argument generics. There are many ways of linking this file +;; into your code... all that needs to happen is this file must be +;; executed after loading TinyCLOS but before any SWIG modules are loaded +;; +;; something like the following +;; (require 'tinyclos) +;; (load "multi-generic") +;; (declare (uses swigmod)) +;; +;; An alternative to loading this scheme code directly is to add a +;; (declare (unit multi-generic)) to the top of this file, and then +;; compile this into the final executable or something. Or compile +;; this into an extension. + +;; Lastly, to override TinyCLOS method creation, two functions are +;; overridden: see the end of this file for which two are overridden. +;; You might want to remove those two lines and then exert more control over +;; which functions are used when. + +;; Comments, bugs, suggestions: send either to chicken-users@nongnu.org or to +;; Author: John Lenz , most code copied from TinyCLOS + +(define (make + 'name "multi-generic" + 'direct-supers (list ) + 'direct-slots '())) + +(letrec ([applicable? + (lambda (c arg) + (memq c (class-cpl (class-of arg))))] + + [more-specific? + (lambda (c1 c2 arg) + (memq c2 (memq c1 (class-cpl (class-of arg)))))] + + [filter-in + (lambda (f l) + (if (null? l) + '() + (let ([h (##sys#slot l 0)] + [r (##sys#slot l 1)] ) + (if (f h) + (cons h (filter-in f r)) + (filter-in f r) ) ) ) )]) + +(add-method compute-apply-generic + (make-method (list ) + (lambda (call-next-method generic) + (lambda args + (let ([cam (let ([x (compute-apply-methods generic)] + [y ((compute-methods generic) args)] ) + (lambda (args) (x y args)) ) ] ) + (cam args) ) ) ) ) ) + + + +(add-method compute-methods + (make-method (list ) + (lambda (call-next-method generic) + (lambda (args) + (let ([applicable + (filter-in (lambda (method) + (let check-applicable ([list1 (method-specializers method)] + [list2 args]) + (cond ((null? list1) #t) + ((null? list2) #f) + (else + (and (applicable? (##sys#slot list1 0) (##sys#slot list2 0)) + (check-applicable (##sys#slot list1 1) (##sys#slot list2 1))))))) + (generic-methods generic) ) ] ) + (if (or (null? applicable) (null? (##sys#slot applicable 1))) + applicable + (let ([cmms (compute-method-more-specific? generic)]) + (sort applicable (lambda (m1 m2) (cmms m1 m2 args))) ) ) ) ) ) ) ) + +(add-method compute-method-more-specific? + (make-method (list ) + (lambda (call-next-method generic) + (lambda (m1 m2 args) + (let loop ((specls1 (method-specializers m1)) + (specls2 (method-specializers m2)) + (args args)) + (cond-expand + [unsafe + (let ((c1 (##sys#slot specls1 0)) + (c2 (##sys#slot specls2 0)) + (arg (##sys#slot args 0))) + (if (eq? c1 c2) + (loop (##sys#slot specls1 1) + (##sys#slot specls2 1) + (##sys#slot args 1)) + (more-specific? c1 c2 arg))) ] + [else + (cond ((and (null? specls1) (null? specls2)) + (##sys#error "two methods are equally specific" generic)) + ;((or (null? specls1) (null? specls2)) + ; (##sys#error "two methods have different number of specializers" generic)) + ((null? specls1) #f) + ((null? specls2) #t) + ((null? args) + (##sys#error "fewer arguments than specializers" generic)) + (else + (let ((c1 (##sys#slot specls1 0)) + (c2 (##sys#slot specls2 0)) + (arg (##sys#slot args 0))) + (if (eq? c1 c2) + (loop (##sys#slot specls1 1) + (##sys#slot specls2 1) + (##sys#slot args 1)) + (more-specific? c1 c2 arg)))) ) ] ) ) ) ) ) ) + +) ;; end of letrec + +(define multi-add-method + (lambda (generic method) + (slot-set! + generic + 'methods + (let filter-in-method ([methods (slot-ref generic 'methods)]) + (if (null? methods) + (list method) + (let ([l1 (length (method-specializers method))] + [l2 (length (method-specializers (##sys#slot methods 0)))]) + (cond ((> l1 l2) + (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1)))) + ((< l1 l2) + (cons method methods)) + (else + (let check-method ([ms1 (method-specializers method)] + [ms2 (method-specializers (##sys#slot methods 0))]) + (cond ((and (null? ms1) (null? ms2)) + (cons method (##sys#slot methods 1))) ;; skip the method already in the generic + ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0)) + (check-method (##sys#slot ms1 1) (##sys#slot ms2 1))) + (else + (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1)))))))))))) + + (##sys#setslot (##sys#slot generic (- (##sys#size generic) 2)) 1 (compute-apply-generic generic)) )) + +(define (multi-add-global-method val sym specializers proc) + (let ((generic (if (procedure? val) val (make 'name (##sys#symbol->string sym))))) + (multi-add-method generic (make-method specializers proc)) + generic)) + +;; Might want to remove these, or perhaps do something like +;; (define old-add-method ##tinyclos#add-method) +;; and then you can switch between creating multi-generics and TinyCLOS generics. +(set! ##tinyclos#add-method multi-add-method) +(set! ##tinyclos#add-global-method multi-add-global-method) diff --git a/Lib/chicken/tinyclos-multi-generic.patch b/Lib/chicken/tinyclos-multi-generic.patch new file mode 100644 index 000000000..2a85f1a63 --- /dev/null +++ b/Lib/chicken/tinyclos-multi-generic.patch @@ -0,0 +1,82 @@ +# This patch is against chicken 1.92, but it should work just fine +# with older versions of chicken. It adds support for mulit-argument +# generics, that is, generics now correctly handle adding methods +# with different lengths of specializer lists + +# Comments, bugs, suggestions send to chicken-users@nongnu.org + +# Patch written by John Lenz + +--- tinyclos.scm.old 2005-04-04 23:35:10.000000000 -0500 ++++ tinyclos.scm 2005-04-05 14:03:26.740306763 -0500 +@@ -868,13 +868,24 @@ + (##tinyclos#slot-set! + generic + 'methods +- (cons method +- (filter-in +- (lambda (m) +- (let ([ms1 (method-specializers m)] +- [ms2 (method-specializers method)] ) +- (not (every2 (lambda (x y) (eq? x y)) ms1 ms2) ) ) ) +- (##tinyclos#slot-ref generic 'methods)))) ++ (let filter-in-method ([methods (##tinyclos#slot-ref generic 'methods)]) ++ (if (null? methods) ++ (list method) ++ (let ([l1 (length (method-specializers method))] ++ [l2 (length (method-specializers (##sys#slot methods 0)))]) ++ (cond ((> l1 l2) ++ (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1)))) ++ ((< l1 l2) ++ (cons method methods)) ++ (else ++ (let check-method ([ms1 (method-specializers method)] ++ [ms2 (method-specializers (##sys#slot methods 0))]) ++ (cond ((and (null? ms1) (null? ms2)) ++ (cons method (##sys#slot methods 1))) ;; skip the method already in the generic ++ ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0)) ++ (check-method (##sys#slot ms1 1) (##sys#slot ms2 1))) ++ (else ++ (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1)))))))))))) + (if (memq generic generic-invocation-generics) + (set! method-cache-tag (vector)) + (%entity-cache-set! generic #f) ) +@@ -946,9 +957,13 @@ + (lambda (args) + (let ([applicable + (filter-in (lambda (method) +- (every2 applicable? +- (method-specializers method) +- args)) ++ (let check-applicable ([list1 (method-specializers method)] ++ [list2 args]) ++ (cond ((null? list1) #t) ++ ((null? list2) #f) ++ (else ++ (and (applicable? (##sys#slot list1 0) (##sys#slot list2 0)) ++ (check-applicable (##sys#slot list1 1) (##sys#slot list2 1))))))) + (generic-methods generic) ) ] ) + (if (or (null? applicable) (null? (##sys#slot applicable 1))) + applicable +@@ -975,8 +990,10 @@ + [else + (cond ((and (null? specls1) (null? specls2)) + (##sys#error "two methods are equally specific" generic)) +- ((or (null? specls1) (null? specls2)) +- (##sys#error "two methods have different number of specializers" generic)) ++ ;((or (null? specls1) (null? specls2)) ++ ; (##sys#error "two methods have different number of specializers" generic)) ++ ((null? specls1) #f) ++ ((null? specls2) #t) + ((null? args) + (##sys#error "fewer arguments than specializers" generic)) + (else +@@ -1235,7 +1252,7 @@ + (define (make-primitive-class "tcp-listener" )) + (define (make 'name "c++-object" 'direct-supers (list ) 'direct-slots '(this))) + +-(set! method-caching-enabled #t) ++;(set! method-caching-enabled #t) + + + ;;; Utilities: -- cgit v1.2.1