From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Marko Rauhamaa Newsgroups: gmane.lisp.guile.user Subject: Re: Message Passing with GOOPS Date: Thu, 25 Jun 2015 01:07:45 +0300 Message-ID: <87mvzolpzi.fsf@elektro.pacujo.net> References: <558B1158.4020607@o2online.de> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: ger.gmane.org 1435183686 16649 80.91.229.3 (24 Jun 2015 22:08:06 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Wed, 24 Jun 2015 22:08:06 +0000 (UTC) Cc: "guile-user@gnu.org" To: Michael Tiedtke Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Thu Jun 25 00:08:06 2015 Return-path: Envelope-to: guile-user@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1Z7spv-0004gV-Ev for guile-user@m.gmane.org; Thu, 25 Jun 2015 00:08:03 +0200 Original-Received: from localhost ([::1]:53139 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Z7spu-00062T-FM for guile-user@m.gmane.org; Wed, 24 Jun 2015 18:08:02 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:44665) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Z7spi-00061O-Rj for guile-user@gnu.org; Wed, 24 Jun 2015 18:07:52 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1Z7spg-0001Dx-N9 for guile-user@gnu.org; Wed, 24 Jun 2015 18:07:50 -0400 Original-Received: from [2001:1bc8:1a0:5384:7a2b:cbff:fe9f:e508] (port=38952 helo=pacujo.net) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Z7spg-0001Dp-E9 for guile-user@gnu.org; Wed, 24 Jun 2015 18:07:48 -0400 Original-Received: from elektro.pacujo.net (192.168.1.200) by elektro.pacujo.net; Thu, 25 Jun 2015 01:07:45 +0300 Original-Received: by elektro.pacujo.net (sSMTP sendmail emulation); Thu, 25 Jun 2015 01:07:45 +0300 In-Reply-To: <558B1158.4020607@o2online.de> (Michael Tiedtke's message of "Wed, 24 Jun 2015 22:21:44 +0200") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.3 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2001:1bc8:1a0:5384:7a2b:cbff:fe9f:e508 X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.14 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 Original-Sender: guile-user-bounces+guile-user=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.user:11865 Archived-At: Michael Tiedtke : > Perhaps it's better to recreate a clean object model without 3,000 > lines of C code like GOOPS. But then GOOPS really creates the illusion > of an object oriented environment with a MOP ... I'd stay away from GOOPS -- it's a leap away from functional programming, IMO. Here's a competing, complete object system I wrote last year: ===begin simpleton.scm================================================== (define-module (pacujo simpleton)) ;;; Return the unique serial number of the object. (define-public (serial-number object) (procedure-property object '%serial-number)) ;(define IMPL 'HTABLE) (define IMPL 'ALIST) (define make-lookup-table #f) (define associate! #f) (define look-up #f) (define iterate #f) (case IMPL ((HTABLE) (set! make-lookup-table make-hash-table) (set! associate! hashq-set!) (set! look-up hashq-ref) (set! iterate hash-for-each-handle)) ((ALIST) (set! make-lookup-table (lambda () (cons #f '()))) (set! associate! (lambda (table key value) (set-cdr! table (assq-set! (cdr table) key value)))) (set! look-up (lambda (table key) (assq-ref (cdr table) key))) (set! iterate (lambda (proc table) (for-each proc (cdr table))))) (else (throw 'Huh?))) ;;; Create and return an object. Parentage must be #f, a parent object ;;; (single inheritance), or a list of parent objects (multiple ;;; inheritance). ;;; ;;; Each of the procedures must have a name and becomes a method of the ;;; object. The methods can be invoked as follows: ;;; ;;; (define object ;;; (let () ;;; (define (my-method a b c) ...) ;;; (make-object #f my-method))) ;;; (object #:my-method 1 2 3) ;;; ;;; Any of the procedures may also be cons cells whose car is a keyword ;;; and cdr is a function. The keyword will then be used as the method ;;; name. (define-public (make-object parentage . procedures) (let ((methods (make-lookup-table))) (define (object method . args) (let ((child (procedure-property object '%child-object))) (if child (apply child method args) (apply-method methods method args)))) (set-procedure-property! object '%methods methods) (set-procedure-property! object '%serial-number (unique)) (inherit object parentage) (let register-methods ((procedures procedures)) (cond ((null? procedures) object) ((pair? (car procedures)) (let ((procedure (cdar procedures)) (method (caar procedures))) (associate! (methods-of object) method procedure) (register-methods (cdr procedures)))) (else (let* ((procedure (car procedures)) (method (symbol->keyword (procedure-name procedure)))) (associate! (methods-of object) method procedure) (register-methods (cdr procedures)))))))) ;;; Apply the parent's method, not the child object's implementation. (define-public (delegate parent method . args) (apply-method (methods-of parent) method args)) ;;; ;;; DESIGN ;;; ;;; A "class" simply a constructor function that calls make-object, ;;; which populates the object structure with methods. ;;; ;;; Each object is a procedure with associated procedure properties ;;; (metainformation): ;;; ;;; * a lookup table ('%methods) containing the method procedures (with ;;; keywords as method keys) ;;; ;;; * an optional child object reference ('%child-object) for virtual ;;; method dispatching ;;; ;;; * a unique serial number ('%serial-number) for the potential ;;; benefit of applications (debugging, logging) ;;; (define unique (let ((uniq 0)) (lambda () (set! uniq (1+ uniq)) uniq))) (define (inherit object parentage) (cond ((not parentage) #f) ((list? parentage) (inherit-multi object parentage)) (else (inherit-single object parentage)))) (define (inherit-single object parent) (iterate (lambda (handle) (associate! (methods-of object) (car handle) (cdr handle))) (methods-of parent)) (set-procedure-property! parent '%child-object object)) (define (inherit-multi object parents) (or (null? parents) (let ((parent (car parents))) (inherit-single object parent) (inherit-multi object (cdr parents))))) (define (methods-of object) (procedure-property object '%methods)) (define (apply-method methods method args) (let ((procedure (look-up methods method))) (if procedure (apply procedure args) (error "No such method" method)))) ===end simpleton.scm==================================================== All you need is the make-object function. Marko