Re: System Scheme (was Re: GOOPS Terminal Class - RnRS POSIX support)
>>> From: Marko Rauhamaa >>> Date: Tue, 23 Jun 2015 11:08:23 +0300 >>> Cc: guile-user@gnu.org >>> >>> Michael Tiedtke : POSIX isn't that important or useful anymore but "full access to POSIX system calls" it has never been. >>> What I'd like is a way to communicate open file descriptors between >>> processes. >> That's highly non-portable, and is bound to produce Guile code that >> works only on some systems. > I'd like to produce Guile code that works on Linux. As it stands, I > can't. Of course you can: write it in C and load it via FFI.
Re: System Scheme (was Re: GOOPS Terminal Class - RnRS POSIX support)
Eli Zaretskii : From: Marko Rauhamaa >> I'd like to produce Guile code that works on Linux. As it stands, I >> can't. > > Of course you can: write it in C and load it via FFI. Well, for that, I don't even need Guile; all I need is gcc. It's a bit of a lame reason to have to escape out of Scheme; after all, Guile already incorporates most system facilities. Note that Python allows you to pass file descriptors over Unix domain sockets. Marko
Message Passing with GOOPS
(use-modules (oop goops))
GOOPS has some nice features (you can even use unexported methods with
generics in 1.8) but there is no message passing paradigm. Objective-C
has /tell/ Racket has /send/ but Guile/GOOPS is missing /call/.
This is a first "raw" definition where the parameter /message/ has to be
a quoted symbol.
(define-method (call (receiver ) message . arguments)
(apply (slot-ref receiver message) arguments))
The class definition still looks like traditional GOOPS but it works.
An example:
(define-class ()
(msg #:init-value (lambda () 'hello-world)))
(define r (make ))
(call r 'msg) => 'hello-world
Now I'd like to have an easier syntax for describing the slot. The
definition might be:
(define-syntax define-message
(syntax-rules ()
((_ (message-name arguments ... ) body ...)
(message-name #:init-value (lambda (arguments ...) body ...)
But the following example doesn't work in 1.8:
(define-class ()
(define-message (phone n)
(repeat n (lambda () (bell) 'rang)) ))
GOOPS complains about malformed slots and *seems* to see the unexpanded
form.*
I could use a little help here, anyone?* Even for the naming scheme:
/send/ is already used by unix sockets and methods are part of the
implementation of generics. Perhaps /message/ isn't that bad.
The missing symbols from my pretext:
(define (natural-number? n)
(and (exact? n)
(integer? n) ; 'integer?' does not check for exactness ...
(> n 0)))
(define-public (repeat n closure)
"Execute closure n times."
(if (not (or (natural-number? n) (= n 0)))
(error "repeat: the parameter n must be an exact natural number
or zero.")
(let loop ((i 0))
(if (< i n)
(begin
(closure)
(loop (1+ i )))
From my pretext.rkt
(define-syntax *broadcast*
(syntax-rules ()
((_ object-list method ...)
(map {lambda (object) (send object method ...)}
object-list
(define-syntax *broadcast**
(syntax-rules ()
((_ object-list method ...)
(map {lambda (object) (send* object method ...)}
object-list
(define-syntax *define/on-delegate*
(syntax-rules ()
((_ delegate-object (method-name ...))
(define (method-name ...)
(send delegate-object method-name ...)) )))
PS
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 ...
Re: Message Passing with GOOPS
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
Re: Message Passing with GOOPS
On 25/06/2015 00:07, Marko Rauhamaa wrote:
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
Nice! What about (define-class () ...)? In GOOPS every
primitive type is (or should be) a class that can be used with multiple
inheritance. It's enough to (use-modules (oop goops)).
Then you're missing /this/, too. Same as my implementation from
yesterday. H
