Chicken/prometheus
SHA256
1
0
Fork 0
Code Issues Pull requests Projects Releases 2 Packages Wiki Activity Actions

In the beginning there was darkness

Browse source
This commit is contained in:
Daniel Ziltener 2024-09-16 13:43:15 +02:00
commit f68de389b2
Signed by: zilti
GPG key ID: B38976E82C9DAE42
12 changed files with 2064 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
.dir-locals.el Normal file
View file

@ -0,0 +1,5 @@
((nil . ((geiser-default-implementation . chicken)
(geiser-scheme-implementation . chicken)
(geiser-active-implementations . (chicken))
(org-confirm-babel-evaluate . nil)))
(org . ((org-confirm-babel-evaluate . nil))))

3
.envrc Normal file
View file

@ -0,0 +1,3 @@
use nix -p chicken chickenPackages_5.chickenEggs.apropos chickenPackages_5.chickenEggs.chicken-doc chickenPackages_5.chickenEggs.srfi-1 chickenPackages_5.chickenEggs.srfi-18 chickenPackages_5.chickenEggs.test-new-egg chickenPackages_5.chickenEggs.openssl chickenPackages_5.chickenEggs.test
export TEST_NEW_EGG_HENRIETTA_CACHE="$(which henrietta-cache)"
export TEST_NEW_EGG_SALMONELLA="$(which salmonella)"

26
LICENSE Normal file
View file

@ -0,0 +1,26 @@
Copyright (C) 2005, 2006 Jorgen Schaefer
Copyright (C) 2024 Daniel Ziltener
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
* Neither the name of the <organization> nor the
names of its contributors may be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

650
README.org Normal file
View file

@ -0,0 +1,650 @@
# Created 2024-09-16 Mon 13:45
#+title: Prometheus
#+author: Daniel Ziltener
#+export_file_name: README.org
#+property: header-args:scheme :session *chicken* :comments none :eval no
#+property: header-args:fundamental :eval no
* Dependencies
Dependencies:
#+name: dependencies
| Egg | Description |
|--------+--------------|
| srfi-1 | List library |
Test dependencies:
#+name: test-dependencies
| Egg | Description |
|------+--------------------------------|
| test | The de-facto standard test egg |
* API
** Hermes
Hermes is a very small object system based solely on messages. It's the basis upon which Prometheus is built. It should be considered internal information of Prometheus, but someone might find it useful, and it is visible in every Prometheus object.
A Hermes object contains messages. A message has a name, a procedure to handle this message, and a type flag on whether the return value of this message should be treated as a parent object. A message-handling procedure is applied to the arguments of the message in addition to two arguments, probably known from Prometheus' method slots by now: /Self/ and /resend/. Indeed, Prometheus' method slots are just a very thing wrapper around Hermes messages.
The =hermes= structure exports a single procedure.
*** API
**** Procedure: ~(make-hermes-object)~
Return a new Hermes object which knows the basic messages.
#+name: hermes-make-hermes-object
#+begin_src scheme
(define (make-hermes-object)
(let ((msg (make-messages)))
(letrec ((self (lambda (name . args)
(messages-handle msg self name args))))
<<hermes-%get-handler-message>>
<<hermes-add-message-message>>
<<hermes-delete-message-message>>
self)))
#+end_src
The basic messages known by all Hermes objects are as follows.
**** Message: *add-message!* /name handler [parent?]/
This adds a message named =name= to the object, upon receiving which, =handler= is applied to =self=, =resend=, and the arguments to the message. If =parent?= is supplied and not false, this message returns a parent object. In this case, it must be callable with no arguments, and must not use =resend=.
#+name: hermes-add-message-message
#+begin_src scheme
(messages-add! msg 'add-message!
(lambda (_ resend name handler . parentl)
(messages-add! msg name handler
(if (null? parentl)
#f
(car parentl))))
#f)
#+end_src
**** Message: *delete-message!* /name/
Remove the handler for the message named =name=. This causes such messages to be handled by parent objects in the future again.
#+name: hermes-delete-message-message
#+begin_src scheme
(messages-add! msg 'delete-message!
(lambda (_ resend name)
(messages-delete! msg name))
#f)
#+end_src
**** Message: *%get-handler* /name receiver args visited/
The message upon which inheritance in Hermes is built. This returns a procedure of no arguments which handles the receiving of the message. This is delayed so that Hermes can check for duplicate handlers, which would be an error.
/Name/ is the name of the message we are looking for. /Receiver/ is the original receiver of the message, to be used as the =self= argument to the handler procedure. /Args/ is a list of arguments. /Visited/ is a list of objects we have seen so far. This is used to detect cycles in the inheritance graph.
This message returns two values. The first one is the handler and the other one the object in which this handler was found. The handler value can also be one of two symbols to signify an error condition. If it's the symbol message-not-understood, then neither this object nor any parents knew how to handle this message. If it's ambiguous-message-send, the same message could be handled by multiple parents in the inheritance graph. The user needs to add a message which resends the ambiguous message unambiguously to the correct parent. In either case, the second return value is #f. The handler procedure itself accepts no arguments, and just runs the message.
#+name: hermes-%get-handler-message
#+begin_src scheme
(messages-add! msg '%get-handler
(lambda (_ resend name receiver args visited)
(get-handler msg self name receiver args visited))
#f)
#+end_src
It is absolutely sufficient for an object to handle only the =%get-handler= message to participate in the inheritance handling of Hermes.
** Prometheus
*** Objects
Prometheus objects are implemented as closures. To send a message to that object, the closure is applied to the message selector (i.e., the slot name), followed by a number of arguments. The return value(s) of the message are returned from this application.
*** Slots
Prometheus knows about three kinds of slots.
/Value slots/ merely store a value which is returned when the corresponding message is received.
/Parent slots/ are just like value slots, but have a special flag marking them as parents.
/Method slots/ contain a procedure which is invoked for messages corresponding to this slot.
The procedure is called with at least two arguments, conventionally called =self= and =resend=. If the message received any arguments, they are also passed, after =resend=. =Self= is the object which received the messages, as opposed to the object where this message handler was found in. =Resend= is a procedure which can be used to resend the message to further parents, if the current method does not wish to handle the message. See [[Inheritance]], for more information about this.
A typical method handler could thus look like:
#+begin_example
(lambda (self resend a b)
(/ (+ a b)
2))
#+end_example
Every slot, regardless of its kind, can be associated with a setter method when it is created. Setter methods receive a single argument, and replaces the value of the corresponding slot with this argument. Setter methods can be created automatically when a given slot is created, and are removed when the corresponding getter slot is removed (but not vice-versa). Because of this, they are sometimes not considered to be slots, even if they are. See [[Setters are Methods]], for an example where this distinction is important.
*** Inheritance
When a slot for a message is not found in the current object, all its parent slots are queried recursively, i.e. parent objects which don't know the slot query their parents, etc.
If no parent knows the slot, the original message receiving object is sent a =message-not-understood= message. If more than one parent knows the slot, the original message receiving object is sent a =ambiguous-message-send= message. See [[Root Objects]], for a documentation of those messages. By default, they signal an error.
Method slots can decide not to handle the message, but rather search the inheritance tree for other handlers. For this purpose, they are passed a procedure commonly called =resend=. See [[Slots]], for an explanation of method slots.
It is important to understand the difference between sending a message to an object, and resending it to the object. When a message is just sent to an object, methods will get that object as the =self= argument. When the method wants information about the object it is handling messages for, this is usually not what is intended.
Consider an account object, which inherited from the account prototype. All the methods are in the account prototype. When a message to modify the account value is sent to the actual account object, the message receiver is the account object. It does not handle this message, so it resends the message to the parent object, the account prototype. The method handler to modify the account value should now know to modify the account object, not the prototype. Hence, the =self= argument should point to the account object, but if the message was just sent directly to the prototype, it =self= would be the prototype. Hence, resending exists. The =resend= procedure allows a method to manually request such a resending.
**** Procedure: *resend* /whereto message args .../
This procedure will try to find a different handler for the given =message=. The handler can be searched for further up the inheritance tree, or even in a totally different object and its parents.
/Whereto/ can be one of the following values.
| #f | Use any parent of the object where this handler was found in. |
| A symbol | Use the object in the parent slot with this name. |
| Any object | Search for handlers in that object. |
/Resend/ is roughly equivalent in concept to CLOS' ~(next-method)~.
*** Root Objects
Since objects are created by sending a =clone= message to other objects, there has to be a kind of root object. Prometheus provides a procedure to create such root objects.
**** Procedure: *make-prometheus-root-object*
This creates a new root object from which other objects can be cloned. This object is independent of any other object, and thus creates a new inheritance tree.
#+begin_src scheme
(define (make-prometheus-root-object)
(let ((o (make-hermes-object)))
(o 'add-message! 'clone root-clone)
(o 'add-message! 'message-not-understood root-message-not-understood)
(o 'add-message! 'ambiguous-message-send root-ambiguous-message-send)
(o 'add-message! 'immediate-slot-list root-immediate-slot-list)
(o 'add-message! 'set-immediate-slot-list! root-set-immediate-slot-list!)
(o 'add-message! 'add-value-slot! root-add-value-slot!)
(o 'add-message! 'add-method-slot! root-add-method-slot!)
(o 'add-message! 'add-parent-slot! root-add-parent-slot!)
(o 'add-message! 'delete-slot! root-delete-slot!)
o))
#+end_src
Prometheus also provides a single existing root object, created with the procedure above. Unless specifically wanted otherwise, using this object as the root object ensures that all prometheus objects share a common ancestor.
**** Message: *clone*
Return a clone of the message recipient. This creates a new object with a single slot, =parent=, which points to the cloned object.
#+begin_src scheme
(define (root-clone self resend)
(let ((child (make-hermes-object)))
(child 'add-message! 'parent
(lambda (self2 resend)
self)
#t)
(child 'add-message! 'immediate-slot-list
(lambda (self2 resend)
'((parent #f parent))))
child))
#+end_src
**** Message: *add-value-slot!* /getter [setter] value/
Add a new value slot to the recipient. The value of the slot can be retrieved with the /getter/ message. If a /setter/ message is given, that message can be used to change the value of the slot.
#+begin_src scheme
(define root-add-value-slot!
(make-getter-setter 'add-value-slot! value 'value
(lambda (self resend)
value)))
#+end_src
**** Message: *add-method-slot!* /getter [setter] proc/
Add a method to the recipient. Sending the object a /getter/ message now invokes /proc/ with the same arguments as the message, in addition to a /self/ argument pointing to the current object and a /resend/ procedure available to resend the message if the method does not want to handle it directly.
The /setter/ message can later be used to change the procedure.
#+begin_src scheme
(define root-add-method-slot!
(make-getter-setter 'add-method-slot! value 'method
value
(lambda (self resend . args)
(apply value self resend args))))
#+end_src
**** Message: *add-parent-slot!* /getter [setter] parent/
Add a parent slot to the recipient. Parent slots are searched for slots not found directly in the object. The /setter/ message, if given, can be used to later change the value of the parent slot.
#+begin_src scheme
(define root-add-parent-slot!
(make-getter-setter 'add-parent-slot! value 'parent
(lambda (self resend)
value)))
#+end_src
**** Message: *delete-slot!* /name/
Delete the slot named /name/ from the receiving object. This also removes the setter corresponding to /name/, if any. Beware that the parents might contain the same slot, so a message send can still succeed even after a slot is deleted.
#+begin_src scheme
(define (root-delete-slot! self resend getter)
(self 'set-immediate-slot-list!
(let loop ((alis (self 'immediate-slot-list)))
(cond
((null? alis)
'())
((eq? getter (caar alis))
(self 'delete-message! (cadar alis))
(loop (cdr alis)))
(else
(cons (car alis)
(loop (cdr alis)))))))
(self 'delete-message! getter))
#+end_src
**** Message: *immediate-slot-list*
This message returns a list of slots in this object. The elements of the list are lists with four elements:
- /getter-name/
- /setter-name/
- =#f=
- /type/, which can be one of the symbols =value=, =method= or =parent=.
For the root object, this is hardcoded:
#+begin_src scheme
(define (root-immediate-slot-list self resend)
'((clone #f #f)
(message-not-understood #f #f)
(ambiguous-message-send #f #f)
(immediate-slot-list set-immediate-slot-list! #f)
(add-value-slot! #f #f)
(add-method-slot! #f #f)
(add-parent-slot! #f #f)
(delete-slot! #f #f)))
#+end_src
Root also gets a setter for the =immediate-slot-list=:
#+begin_src scheme
(define (root-set-immediate-slot-list! self resend new)
(self 'add-message! 'immediate-slot-list
(lambda (self resend)
new)))
#+end_src
**** Message: *message-not-understood* /message args/
This is received when the message /message/ with arguments /args/ to the object was not understood. The root object just signals an error.
#+begin_src scheme
(define (root-message-not-understood self resend message args)
(error "Message not understood" self message args))
#+end_src
**** Message: *ambiguous-message-send* /message args/
This is received when the message /message/ with arguments /args/ to the object would have reached multiple parents. The root object just signals an error.
#+begin_src scheme
(define (root-ambiguous-message-send self resend message args)
(error "Message ambiguous" self message args))
#+end_src
**** Variable: **the-root-object**
This is the default root object. If not really intended otherwise, this should be used as the root of the object hierarchy in a program.
Root objects contain a number of slots by default.
#+begin_src scheme
(define *the-root-object* (make-prometheus-root-object))
#+end_src
*** Syntactic Sugar
Prometheus provides two forms of syntactic sugar for common operations on objects.
A very common operation is to add method slots to an object, which usually looks like this:
#+begin_example
(obj 'add-method-slot!
'average
(lambda (self resend a b)
(/ (+ a b)
2)))
#+end_example
Using the special form of =define-method=, this can be shortened to:
#+begin_example
(define-method (obj 'average self resend a b)
(/ (+ a b)
2))
#+end_example
**** Syntax: *define-method* /(obj 'message self resend . args) body .../
This is syntactic sugar for the often-used idiom to define a method slot, by sending a =add-method-slot!= message with a /message/ name and a lambda form with /self/, /resend/ and /args/ formals, and a /body/.
Another common operation is to clone an object, and add a number of value and method slots:
#+begin_example
(define o (*the-root-object* 'clone))
(o 'add-value-slot! 'constant 'set-constant! 5)
(o 'add-method-slot! 'add
(lambda (self resend summand)
(+ summand (self 'constant))))
#+end_example
This can be more succintly written as:
#+begin_example
(define-object o (*the-root-object*)
(constant set-constant! 5)
((add self resend summand)
(+ summand (self 'constant)))
#+end_example
#+begin_src scheme
(define-syntax define-method
(syntax-rules ()
((_ (obj 'message self resend args ...)
body1 body ...)
(obj 'add-method-slot! 'message
(lambda (self resend args ...)
body1 body ...)))))
#+end_src
**** Syntax: *define-object* /name (parent other-parents ...) slots .../
This is syntactic sugar for the typical actions of cloning an object from a /parent/ object, and adding more slots.
/other-parents/ is a list of ~(name object)~ lists, where each /object/ is added as a parent slot named /name/.
/slots/ is a list of slot specifications, either ~(getter value)~ or ~(getter setter value)~ for value slots, or ~((name self resend args ...) body ...)~ for method slots.
#+begin_src scheme
(define-syntax define-object
(syntax-rules ()
((_ name (creation-parent (parent-name parent-object) ...)
slots ...)
(define name (let ((o (creation-parent 'clone)))
(o 'add-parent-slot! 'parent-name parent-object)
...
(define-object/add-slots! o slots ...)
o)))))
#+end_src
*** Private Messages
Message names in Prometheus don't have any required type. They are only compared using =eq?=. Because of this, any kind of Scheme object can be used as a message name. This means that it is possible to use a private Scheme value—for example, a freshly-allocated list—as a slot name. This can be used to keep slot names private, since it is not possible to create an object which is =eq?= to such an object except by receiving a reference to that object.
* Examples
** Simple Account Object
This is from the file =examples/account.scm= in the Prometheus distribution:
#+begin_example
;;; This is a simple account-keeping object.
;;; It's just like a normal object
(define account (*the-root-object* 'clone))
;;; But it has a balance
(account 'add-value-slot! 'balance 'set-balance! 0)
;;; Which can be modified
(account 'add-method-slot! 'payment!
(lambda (self resend amount)
(self 'set-balance!
(+ (self 'balance)
amount))))
;;; Some tests:
(define a1 (account 'clone))
(define a2 (account 'clone))
(a1 'payment! 100)
(a2 'payment! 200)
(a1 'balance)
;;; => 100
(a2 'balance)
;;; => 200
(a1 'payment! -20)
(a1 'balance)
;;; => 80
;;; The typing for the slot definitions above can be rather tedious.
;;; Prometheus provides syntactic sugar for those operations.
;;; A method can be added with the DEFINE-METHOD syntax. This code is
;;; equivalent to the code above which adds the PAYMENT! method:
(define-method (account 'payment! self resend amount)
(self 'set-balance!
(+ (self 'balance)
amount)))
;;; And this defines the whole object with the BALANCE slot and the
;;; PAYMENT! method just as above:
(define-object account (*the-root-object*)
(balance set-balance! 0)
((payment! self resend amount)
(self 'set-balance!
(+ (self 'balance)
amount))))
#+end_example
** Creating Slots on Use
This is from the file =examples/create-on-use.scm= in the Prometheus distribution:
#+begin_example
;;; A simple object which creates slots as they are used. This
;;; demonstrates the use of the MESSAGE-NOT-UNDERSTOOD error message.
;;; Slots behave like value slots, and the accessors use a second
;;; argument as the "default value". If that is not given, (if #f #f)
;;; is used, which is usually not what is intended.
(define-object create-on-use-object (*the-root-object*)
((message-not-understood self resend slot args)
(self 'add-method-slot! slot (lambda (self resend . default)
(if (pair? args)
(car args))))
(self slot)))
#+end_example
** Diamond Inheritance
This is from the file =examples/diamond.scm= in the Prometheus distribution:
#+begin_example
;;; This requires SRFI-23
;;; We create an amphibious vehicle which inherits from a car - which
;;; can only drive on ground - and from a ship - which can only drive
;;; on water. Roads have a type of terrain. The amphibious vehicle
;;; drives along the road, using either the drive method of the car or
;;; of the ship.
;;; First, let's build a road.
(define-object road-segment (*the-root-object*)
(next set-next! #f)
(type set-type! 'ground)
((clone self resend next type)
(let ((o (resend #f 'clone)))
(o 'set-next! next)
(o 'set-type! type)
o)))
;;; Create a road with the environment types in the ENVIRONMENTS list.
(define (make-road environments)
(if (null? (cdr environments))
(road-segment 'clone
#f
(car environments))
(road-segment 'clone
(make-road (cdr environments))
(car environments))))
;;; Now, we need a vehicle - the base class.
(define-object vehicle (*the-root-object*)
(location set-location! #f)
((drive self resend)
#f)
((clone self resend . location)
(let ((o (resend #f 'clone)))
(if (not (null? location))
(o 'set-location! (car location)))
o)))
;;; All vehicles have to drive quite similarily - no one stops us from
;;; using a normal helper procedure here.
(define (handle-drive self handlers)
(let ((next ((self 'location) 'next)))
(cond
((not next)
(display "Yay, we're at the goal!")
(newline))
((assq (next 'type) handlers)
=> (lambda (handler)
((cdr handler) next)))
(else
(error "Your vehicle crashed on a road segment of type"
(next 'type))))))
;;; And a car. Hm. Wait. A CAR is something pretty specific in Scheme,
;;; make an automobile instead.
(define-object automobile (vehicle)
((drive self resend)
(resend #f 'drive)
(handle-drive self `((ground . ,(lambda (next)
(display "*wrooom*")
(newline)
(self 'set-location! next)))))))
;;; And now a ship, for waterways.
(define-object ship (vehicle)
((drive self resend)
(resend #f 'drive)
(handle-drive self `((water . ,(lambda (next)
(display "*whoosh*")
(newline)
(self 'set-location! next)))))))
;;; And an amphibious vehicle for good measure!
(define-object amphibious (ship (ground-parent automobile))
((drive self resend)
(handle-drive self `((water . ,(lambda (next)
(resend 'parent 'drive)))
(ground . ,(lambda (next)
(resend 'ground-parent 'drive)))))))
;;; The code above works already. We can clone ships, automobiles and
;;; amphibious vehicles as much as we want, and they drive happily on
;;; roads. But we could extend this, and add gas consumption. This
;;; will even modify already existing vehicles, because they inherit
;;; from the vehicle object we extend:
(vehicle 'add-value-slot! 'gas 'set-gas! 0)
(vehicle 'add-value-slot! 'needed-gas 'set-needed-gas! 0)
(define-method (vehicle 'drive self resend)
(let ((current-gas (self 'gas))
(needed-gas (self 'needed-gas)))
(if (>= current-gas needed-gas)
(self 'set-gas! (- current-gas needed-gas))
(error "Out of gas!"))))
;;; If you want to test the speed of the implementation:
(define (make-infinite-road)
(let* ((ground (road-segment 'clone #f 'ground))
(water (road-segment 'clone ground 'water)))
(ground 'set-next! water)
ground))
(define (test n)
(let ((o (amphibious 'clone (make-infinite-road))))
(do ((i 0 (+ i 1)))
((= i n) #t)
(o 'drive))))
#+end_example
* Pitfalls
** Setters are Methods
Since Prometheus does not allow for ambiguous message sends, and setter methods are just messages, this can lead to a confusing situation. Consider the following code:
#+begin_example
(define o1 (*the-root-object* 'clone))
(o1 'add-value-slot! 'foo 'set-foo! 1)
(define o2 (o1 'clone))
(define o3 (o2 'clone))
(o3 'add-parent-slot! 'parent2 o1)
#+end_example
This creates a diamond-shaped inheritance tree. Now it is possible to send a =set-foo!= message to =o3=, though it inherits this slot from two parents, the slot is ultimately inherited from the same object. But now witness the following:
#+begin_example
> (o3 'foo)
=> 3
> (o2 'set-foo! 2)
> (o3 'set-foo! 3)
error--> Ambiguous message send
#+end_example
What happened here? The =set-foo!= message added the foo slot to =o2=, but with it, also the associated method to mutate that slot, =set-foo!=. So, sending =set-foo!= to =o3= will find the same message both in =o1= and =o2=, and cause an ambiguous message send.
Conclusion: Be extra careful with multiple inheritance.
* About this egg
** Source
The source is available at [[https://forgejo.lyrion.ch/Chicken/prometheus]].
** Author
Daniel Ziltener, Jorgen Schaefer
** Version History
#+name: version-history
| 1.0.0 | Port to Chicken 5 |
* License
#+begin_src fundamental
Copyright (C) 2022 Daniel Ziltener
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
,* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
,* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
,* Neither the name of the <organization> nor the
names of its contributors may be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#+end_src

162
hermes-impl.scm Normal file
View file

@ -0,0 +1,162 @@
(import
(scheme)
(srfi-1) ;;List library
)
(define (make-hermes-object)
(let ((msg (make-messages)))
(letrec ((self (lambda (name . args)
(messages-handle msg self name args))))
(messages-add! msg '%get-handler
(lambda (_ resend name receiver args visited)
(get-handler msg self name receiver args visited))
#f)
(messages-add! msg 'add-message!
(lambda (_ resend name handler . parentl)
(messages-add! msg name handler
(if (null? parentl)
#f
(car parentl))))
#f)
(messages-add! msg 'delete-message!
(lambda (_ resend name)
(messages-delete! msg name))
#f)
self)))
(define (alist-set! alist name value)
(cond
((assq name alist)
=> (lambda (entry)
(set-cdr! entry value)
alist))
(else
(alist-cons name value alist))))
(define-record-type messages
(%make-messages alist parents)
messages?
(alist messages-alist set-messages-alist!)
(parents messages-parents set-messages-parents!))
(define (make-messages)
(%make-messages '() '()))
(define (messages-add! msg name handler parent?)
(set-messages-alist! msg
(alist-set! (messages-alist msg)
name handler))
(if parent?
(set-messages-parents! msg
(alist-set! (messages-parents msg)
name handler))))
(define (messages-delete! msg name)
(set-messages-alist! msg
(alist-delete! name
(messages-alist msg)
eq?))
(set-messages-parents! msg
(alist-delete! name
(messages-parents msg)
eq?)))
;;; Do a direct lookup (as opposed to asking the parents) for a
;;; message handler in the record.
(define (messages-direct-lookup msg name)
(cond
((assq name (messages-alist msg))
=> cdr)
(else
#f)))
;;; Ask the parents in the messages record for handlers. This returns
;;; two values as explained above. To enable the
;;; AMBIGUOUS-MESSAGE-SEND error, the parent list is searched
;;; completely even when a handler is found.
(define (messages-parent-lookup msg self name receiver args visited)
(let loop ((alis (messages-parents msg))
(handler #f)
(found #f))
(if (null? alis)
(if handler
(values handler found)
(values 'message-not-understood #f))
(receive (new new-found)
(((cdar alis)
receiver
(lambda args
(error "Parent slots must not use resend."
receiver name args)))
'%get-handler name receiver args (cons self visited))
(case new
((message-not-understood)
(loop (cdr alis)
handler
found))
((ambiguous-message-send)
(values 'ambiguous-message-send
#f))
(else
(if (and handler
(and (not (eq? found new-found))))
(values 'ambiguous-message-send
#f)
(loop (cdr alis)
new
new-found))))))))
;;; Handle a single message, checking for errors.
(define (messages-handle msg self name args)
(receive (handler found)
(get-handler msg self name self args '())
(run-with-error-checking handler self name args)))
;;; Return the appropriate handler procedure.
(define (get-handler msg self name receiver args visited)
(if (memq self visited)
(values 'message-not-understood #f)
(cond
((messages-direct-lookup msg name)
=> (lambda (handler)
(values (lambda ()
(apply handler
receiver
(make-resender msg self receiver visited)
args))
self)))
(else
(messages-parent-lookup msg self name receiver args visited)))))
;;; Create a resender for the message.
(define (make-resender msg self receiver visited)
(lambda (target name . args)
(receive (handler found)
(cond
((eq? target #f) ; ask parents
(messages-parent-lookup msg self name receiver args visited))
((or (eq? target self) ; ask this object
(eq? target #t)) ; hystorical syntax
(get-handler msg self name receiver args visited))
((symbol? target) ; ask named parent
((self target) '%get-handler name receiver args (cons self visited)))
(else ; ask that object
(target '%get-handler name receiver args (cons self visited))))
(run-with-error-checking handler self name args))))
;;; Signal the appropriate errors, if handler is not a procedure.
;;; Else, call that handler.
(define (run-with-error-checking handler self name args)
(case handler
((message-not-understood)
(if (eq? name 'message-not-understood)
(error "Message MESSAGE-NOT-UNDERSTOOD not understood"
self args)
(self 'message-not-understood name args)))
((ambiguous-message-send)
(if (eq? name 'ambiguous-message-send)
(error "Message AMBIGUOUS-MESSAGE-SEND is ambiguous"
self args)
(self 'ambiguous-message-send name args)))
(else
(handler))))

13
hermes.scm Normal file
View file

@ -0,0 +1,13 @@
(module (hermes)
(make-hermes-object
make-messages
messages-add!
messages-delete!
messages-direct-lookup
messages-parent-lookup
messages-handle
get-handler
make-resender
run-with-error-checking)
(import (chicken base))
(include-relative "hermes-impl.scm"))

149
prometheus-impl.scm Normal file
View file

@ -0,0 +1,149 @@
(import
(scheme)
(srfi 1)
(hermes))
(define-syntax make-getter-setter
(syntax-rules ()
((make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER)
(make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER PURE-GETTER))
((make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER SETABLE-GETTER)
(case-lambda
((self resend getter VALUE)
(self 'delete-slot! getter)
(self 'set-immediate-slot-list!
(alist-cons getter
(list #f TYPE)
(self 'immediate-slot-list)))
(self 'add-message! getter PURE-GETTER (eq? TYPE 'parent)))
((self resend getter setter VALUE)
(self 'delete-slot! getter)
(self 'delete-slot! setter)
(self 'set-immediate-slot-list!
(alist-cons getter
(list setter TYPE)
(self 'immediate-slot-list)))
(self 'add-message! getter SETABLE-GETTER (eq? TYPE 'parent))
(self 'add-message! setter
(lambda (self2 resend new)
(if (eq? self2 self)
(set! VALUE new)
(self2 'MESSAGE getter setter new)))))))))
(define (make-prometheus-root-object)
(let ((o (make-hermes-object)))
(o 'add-message! 'clone root-clone)
(o 'add-message! 'message-not-understood root-message-not-understood)
(o 'add-message! 'ambiguous-message-send root-ambiguous-message-send)
(o 'add-message! 'immediate-slot-list root-immediate-slot-list)
(o 'add-message! 'set-immediate-slot-list! root-set-immediate-slot-list!)
(o 'add-message! 'add-value-slot! root-add-value-slot!)
(o 'add-message! 'add-method-slot! root-add-method-slot!)
(o 'add-message! 'add-parent-slot! root-add-parent-slot!)
(o 'add-message! 'delete-slot! root-delete-slot!)
o))
(define (root-clone self resend)
(let ((child (make-hermes-object)))
(child 'add-message! 'parent
(lambda (self2 resend)
self)
#t)
(child 'add-message! 'immediate-slot-list
(lambda (self2 resend)
'((parent #f parent))))
child))
(define root-add-value-slot!
(make-getter-setter 'add-value-slot! value 'value
(lambda (self resend)
value)))
(define root-add-method-slot!
(make-getter-setter 'add-method-slot! value 'method
value
(lambda (self resend . args)
(apply value self resend args))))
(define root-add-parent-slot!
(make-getter-setter 'add-parent-slot! value 'parent
(lambda (self resend)
value)))
(define (root-delete-slot! self resend getter)
(self 'set-immediate-slot-list!
(let loop ((alis (self 'immediate-slot-list)))
(cond
((null? alis)
'())
((eq? getter (caar alis))
(self 'delete-message! (cadar alis))
(loop (cdr alis)))
(else
(cons (car alis)
(loop (cdr alis)))))))
(self 'delete-message! getter))
(define (root-immediate-slot-list self resend)
'((clone #f #f)
(message-not-understood #f #f)
(ambiguous-message-send #f #f)
(immediate-slot-list set-immediate-slot-list! #f)
(add-value-slot! #f #f)
(add-method-slot! #f #f)
(add-parent-slot! #f #f)
(delete-slot! #f #f)))
(define (root-set-immediate-slot-list! self resend new)
(self 'add-message! 'immediate-slot-list
(lambda (self resend)
new)))
(define (root-message-not-understood self resend message args)
(error "Message not understood" self message args))
(define (root-ambiguous-message-send self resend message args)
(error "Message ambiguous" self message args))
(define *the-root-object* (make-prometheus-root-object))
(define-syntax define-method
(syntax-rules ()
((_ (obj 'message self resend args ...)
body1 body ...)
(obj 'add-method-slot! 'message
(lambda (self resend args ...)
body1 body ...)))))
(define-syntax define-object
(syntax-rules ()
((_ name (creation-parent (parent-name parent-object) ...)
slots ...)
(define name (let ((o (creation-parent 'clone)))
(o 'add-parent-slot! 'parent-name parent-object)
...
(define-object/add-slots! o slots ...)
o)))))
(define-syntax define-object/add-slots!
(syntax-rules ()
((_ o)
(values))
((_ o ((method-name . method-args) body ...)
slots ...)
(begin
(o 'add-method-slot! 'method-name (lambda method-args
body ...))
(define-object/add-slots! o slots ...)))
((_ o (slot-getter slot-setter slot-value)
slots ...)
(begin
(o 'add-value-slot! 'slot-getter 'slot-setter slot-value)
(define-object/add-slots! o slots ...)))
((_ o (slot-getter slot-value)
slots ...)
(begin
(o 'add-value-slot! 'slot-getter slot-value)
(define-object/add-slots! o slots ...)))))

14
prometheus.egg Normal file
View file

@ -0,0 +1,14 @@
;; -*- Scheme -*-
((author "Daniel Ziltener")
(synopsis "The Prometheus Object System.")
(category oop)
(license "BSD")
(version "1.0.0")
(dependencies srfi-1)
(test-dependencies test)
(components
(extension hermes
(csc-options "-sJ"))
(extension prometheus
(csc-options "-sJ")
(component-dependencies hermes))))

1017
prometheus.org Normal file
View file

File diff suppressed because it is too large Load diff

4
prometheus.release-info Normal file
View file

@ -0,0 +1,4 @@
;; -*- Scheme -*-
(repo git "https://forgejo.lyrion.ch/Chicken/prometheus.git")
(uri targz "https://forgejo.lyrion.ch/Chicken/prometheus/archive/{egg-release}.tar.gz")
(release "1.0.0") ;; Port to Chicken 5

7
prometheus.scm Normal file
View file

@ -0,0 +1,7 @@
(module (prometheus)
(make-prometheus-root-object
*the-root-object*
define-method
define-object)
(import (chicken base))
(include-relative "prometheus-impl.scm"))

14
tests/run.scm Normal file
View file

@ -0,0 +1,14 @@
(import (chicken string))
(import test
(chicken base)
(chicken format)
(chicken port)
(chicken string)
(chicken io)
(test) ;;The de-facto standard test egg
)
(include-relative "../hermes-impl.scm")
(include-relative "../prometheus-impl.scm")
(test-exit)