From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Andreas Rottmann Newsgroups: gmane.lisp.guile.user,gmane.lisp.guile.devel Subject: GOOPS-based SRFI-35 implementation Date: Sat, 28 Feb 2004 16:53:42 +0100 Sender: guile-user-bounces+guile-user=m.gmane.org@gnu.org Message-ID: <87k7278ak9.fsf@alice.rotty.yi.org> NNTP-Posting-Host: deer.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: sea.gmane.org 1077983934 12100 80.91.224.253 (28 Feb 2004 15:58:54 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Sat, 28 Feb 2004 15:58:54 +0000 (UTC) Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Sat Feb 28 16:58:47 2004 Return-path: Original-Received: from monty-python.gnu.org ([199.232.76.173]) by deer.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 1Ax6rW-0001pp-00 for ; Sat, 28 Feb 2004 16:58:47 +0100 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.30) id 1Ax6o4-0006DU-7F for guile-user@m.gmane.org; Sat, 28 Feb 2004 10:55:12 -0500 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.30) id 1Ax6nQ-000678-L3 for guile-user@gnu.org; Sat, 28 Feb 2004 10:54:32 -0500 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.30) id 1Ax6ms-0005U2-So for guile-user@gnu.org; Sat, 28 Feb 2004 10:54:30 -0500 Original-Received: from [213.165.64.20] (helo=mail.gmx.net) by monty-python.gnu.org with smtp (Exim 4.30) id 1Ax6ms-0005TW-7z for guile-user@gnu.org; Sat, 28 Feb 2004 10:53:58 -0500 Original-Received: (qmail 21830 invoked by uid 65534); 28 Feb 2004 15:53:54 -0000 Original-Received: from chello212186006140.401.14.univie.teleweb.at (EHLO garibaldi) (212.186.6.140) by mail.gmx.net (mp007) with SMTP; 28 Feb 2004 16:53:54 +0100 X-Authenticated: #3102804 Original-Received: from ivanova.rhinosaur.lan ([192.168.1.9] helo=ivanova) by garibaldi with esmtp (Exim 4.30) id 1Ax6me-0001IP-29; Sat, 28 Feb 2004 16:53:44 +0100 Original-Received: from andy by ivanova with local (Exim 4.30) id 1Ax6md-0000pJ-4Z; Sat, 28 Feb 2004 16:53:43 +0100 Original-To: Guile Users , guile-devel@gnu.org User-Agent: Gnus/5.1006 (Gnus v5.10.6) Emacs/21.3 (gnu/linux) X-Spam-Score: -4.9 (----) X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.2 Precedence: list List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org Xref: main.gmane.org gmane.lisp.guile.user:2856 gmane.lisp.guile.devel:3461 X-Report-Spam: http://spam.gmane.org/gmane.lisp.guile.user:2856 --=-=-= Hi! I just wanted to announce that I've been working a bit on a GOOPS-based implementation of SRFI-35 ("Conditions"). It seems to basically work, except compound conditions, which are not-yet implemented. My implementation is based on the SRFI reference implementation, but differs a good deal because it uses GOOPS classes instead of SRFI-9 ("Defining record types"). Right now, the thing lives in the module (itla srfi-35), since my iTLA thingy[0] will use it. I'd like comments: [0] http://yi.org/rotty/ITLA * On issues with the code * How to proceed to get this into Guile * How I can ship it with iTLA in a way that's compatible with both Guile versions that don't come with this SRFI and Guile CVS (which might come with it in the near future /mehopes). I thought installing it into /usr/[local/]guile/srfi/srfi-35.scm might work, since this will be used if there is no such module in /usr/[local/]guile/1.X/srfi and the one in Guile will be prefered if present. * Everything else that matters (or doesn't ;-) The latest & greatest code is always available via Arch (see [0]), though I've attached the code and test cases (basically the examples in the SRFI; non-working stuff is commented out). --=-=-= Content-Disposition: inline; filename=srfi-35.scm (define-module (itla srfi-35) #:use-module (oop goops) #:use-module (oop goops util) #:use-module (srfi srfi-1) ;; (oop goops util) and (srfi srfi-1) both define any, every #:duplicates last #:export (make-condition-type condition-type? condition? condition-has-type? condition-ref make-condition make-compound-condition extract-condition &condition &message &error ) #:export-syntax (define-condition-type condition)) (define-class ()) (define-class () (%name #:accessor condition-type-name) #:metaclass ) (define (condition-type? thing) (is-a? thing )) (define (condition-type-all-fields type) (fold-right (lambda (slot lst) (let ((name (car slot))) (if (eq? name '%name) lst (cons name lst)))) '() (class-slots type))) (define (make-condition-type name supertype fields) (if (not (symbol? name)) (error "make-condition-type: name is not a symbol" name)) (if (not (condition-type? supertype)) (error "make-condition-type: supertype is not a condition type" supertype)) (if (not (null? (lset-intersection eq? (condition-type-all-fields supertype) fields))) (error "make-condition-type: duplicate field name" )) (make-class (list supertype) (map list fields) #:name name)) (define-macro (define-condition-type ?name ?supertype ?predicate . ?field-acc) `(begin (define ,?name (make-condition-type ',?name ,?supertype (map car ',?field-acc))) (define (,?predicate thing) (and (condition? thing) (condition-has-type? thing ,?name))) ,@(map (lambda (f-a) ;;(format #t "defining accesor: ~S\n" (cadr f-a)) `(define (,(cadr f-a) condition) (condition-ref (extract-condition condition ,?name) ',(car f-a)))) ?field-acc))) ;; Stolen from oop/goops.scm (define (list2set l) (let loop ((l l) (res '())) (cond ((null? l) res) ((memq (car l) res) (loop (cdr l) res)) (else (loop (cdr l) (cons (car l) res)))))) ;; This should be in goops.scm, really (define-public (class-supers c) (letrec ((allsubs (lambda (c) (cons c (mapappend allsubs (class-direct-supers c)))))) (list2set (cdr (allsubs c))))) (define (condition-subtype? subtype supertype) (or (equal? subtype supertype) (memq supertype (class-supers subtype)))) (define (condition-type-field-supertype condition-type field) (let loop ((condition-type condition-type)) (cond ((not condition-type) #f) ((memq field (condition-type-fields condition-type)) condition-type) (else (loop (condition-type-supertype condition-type)))))) (define (condition? thing) (is-a? thing )) (define (make-condition type . field-plist) (let ((alist (let loop ((plist field-plist)) (if (null? plist) '() (cons (cons (car plist) (cadr plist)) (loop (cddr plist))))))) (if (not (lset= eq? (condition-type-all-fields type) (map car alist))) (error "condition fields don't match condition type" (condition-type-all-fields type) (map car alist))) (let ((condition (make type))) (for-each (lambda (pr) (slot-set! condition (car pr) (cdr pr))) alist) condition))) (define (condition-has-type? condition type) (if (any (lambda (has-type) (condition-subtype? has-type type)) (condition-types condition)) #t #f)) (define condition-ref slot-ref) (define (type-field-alist-ref type-field-alist field) (let loop ((type-field-alist type-field-alist)) (cond ((null? type-field-alist) (error "type-field-alist-ref: field not found" type-field-alist field)) ((assq field (cdr (car type-field-alist))) => cdr) (else (loop (cdr type-field-alist)))))) (define-class () (%components #:init-keyword #:components)) (define (make-compound-condition condition-1 . conditions) (if (null? conditions) condition-1 (make #:components (cons condition-1 conditions)))) (define (extract-condition condition type) (if (not (condition-subtype? (class-of condition) type)) (error "extract-condition: invalid condition type" condition type)) condition) (define-macro (condition . forms) ;; forms: (type1 (field1 value1) ...) ...) `(make-compound-condition ,@(map (lambda (form) `(make-condition ,(car form) ,@(fold (lambda (entry lst) (cons `(quote ,(car entry)) (cons (cadr entry) lst))) '() (cdr form)))) forms))) (define (type-field-alist->condition type-field-alist) (really-make-condition (map (lambda (entry) (cons (car entry) (map (lambda (field) (or (assq field (cdr entry)) (cons field (type-field-alist-ref type-field-alist field)))) (condition-type-all-fields (car entry))))) type-field-alist))) (define (condition-types condition) (let ((own-class (class-of condition))) (cons own-class (class-direct-supers own-class)))) (define &condition ) (define-condition-type &message &condition message-condition? (message condition-message)) (define-condition-type &serious &condition serious-condition?) (define-condition-type &error &serious error?) ;;; arch-tag: 1145fba2-0008-4c99-8304-a53cdcea50f9 --=-=-= Content-Disposition: inline; filename=srfi-35.test #!/bin/sh exec ${srcdir:-.}/guile-test-env guile -s "$0" "$@" !# (define-module (test-suite test-srfi-35) #:use-module (itla srfi-35) #:use-module (test-suite lib)) (define-condition-type &c &condition c? (x c-x)) (define-condition-type &c1 &c c1? (a c1-a)) (define-condition-type &c2 &c c2? (b c2-b)) (define v1 (make-condition &c1 'x "V1" 'a "a1")) (define v2 (condition (&c2 (x "V2") (b "b2")))) ; (define v3 (condition (&c1 (x "V3/1") (a "a3")) ; (&c2 (b "b3")))) (with-test-prefix "condition of type &c1" (pass-if "supertype predicate" (c? v1)) (pass-if "predicate" (c1? v1)) (pass-if "sibling predicate" (not (c2? v1))) (pass-if "parent field accessor" (string=? (c-x v1) "V1")) (pass-if "field accessor" (string=? (c1-a v1) "a1"))) (with-test-prefix "condition of type &c2" (pass-if "supertype predicate" (c? v2)) (pass-if "predicate" (c2? v2)) (pass-if "sibling predicate" (not (c1? v2))) (pass-if "parent field accessor" (string=? (c-x v2) "V2")) (pass-if "field accessor" (string=? (c2-b v2) "b2"))) ; (with-test-prefix "condition of compound type (&c1 &c2)" ; (pass-if "supertype predicate" (c? v2)) ; (pass-if "c1 predicate" (c1? v2)) ; (pass-if "c2 predicate" (c2? v2)) ; (pass-if "parent field accessor" (string=? (c-x v2) "V3/1")) ; (pass-if "c1 field accessor" (string=? (c1-a v2) "a3")) ; (pass-if "c2 field accessor" (string=? (c2-b v2) "b3"))) ; (define v4 (make-compound-condition v1 v2)) ; (c? v4) => #t ; (c1? v4) => #t ; (c2? v4) => #t ; (c-x v4) => "V1" ; (c1-a v4) => "a1" ; (c2-b v4) => "b2" ; (define v5 (make-compound-condition v2 v3)) ; (c? v5) => #t ; (c1? v5) => #t ; (c2? v5) => #t ; (c-x v5) => "V2" ; (c1-a v5) => "a3" ; (c2-b v5) => "b2" ;; Local Variables: ;; mode: scheme ;; End: ;;; arch-tag: 774c4de9-d9f8-4754-8d40-38912ec7f3a1 --=-=-= Cheers, Andy -- Andreas Rottmann | Rotty@ICQ | 118634484@ICQ | a.rottmann@gmx.at http://yi.org/rotty | GnuPG Key: http://yi.org/rotty/gpg.asc Fingerprint | DFB4 4EB4 78A4 5EEE 6219 F228 F92F CFC5 01FD 5B62 Make free software, not war! --=-=-= Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline _______________________________________________ Guile-user mailing list Guile-user@gnu.org http://mail.gnu.org/mailman/listinfo/guile-user --=-=-=--