Changeset 14451 in project


Ignore:
Timestamp:
04/26/09 17:03:14 (11 years ago)
Author:
sjamaan
Message:

Port Prometheus-2 to Chicken, using the clean, unmodified code from the release

Location:
release/4/prometheus
Files:
24 added
3 deleted
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/prometheus/prometheus.meta

    r12594 r14451  
    33((synopsis "The Prometheus prototype-based object system")
    44 (author "Jorgen Schaefer")
     5 (needs s48-modules)
    56 (category oop)
    67 (license "GPL-2")
     
    910 (files "prometheus.scm"
    1011        "prometheus.setup"
    11         "prometheus.html"
    12         "prometheus-manual.html"))
     12        "prometheus.html"))
  • release/4/prometheus/prometheus.scm

    r12594 r14451  
    1 ;;; prometheus.scm --- The user interface to the Prometheus object system
     1;; These lines can be removed when Chicken installs modules for its SRFIs
     2(module srfi-8 (receive) (import (only chicken receive)))
     3(module srfi-9 (define-record-type) (import (only chicken define-record-type)))
     4(module srfi-16 (case-lambda fx=) (import (only chicken case-lambda fx=)))
     5(module srfi-23 (error) (import (only chicken error)))
    26
    3 ;; Copyright (C) 2005 Jorgen Schaefer
     7;; Loading srfi-1 is required because s48-modules only handles importing
     8;; of modules, not loading the associated libraries.
     9(require-extension s48-modules srfi-1)
    410
    5 ;; Author: Jorgen Schaefer <forcer@forcix.cx>
     11;; This hack is required because "include" includes first, and expands later,
     12;; causing the s48-modules file to think the forms are in _this_ file here.
     13(begin-for-syntax (set! ##sys#current-source-filename "prometheus-2/scheme/packages.scm"))
    614
    7 ;; This program is free software; you can redistribute it and/or
    8 ;; modify it under the terms of the GNU General Public License
    9 ;; as published by the Free Software Foundation; either version 2
    10 ;; of the License, or (at your option) any later version.
    11 
    12 ;; This program is distributed in the hope that it will be useful,
    13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
    14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    15 ;; GNU General Public License for more details.
    16 
    17 ;; You should have received a copy of the GNU General Public License
    18 ;; along with this program; if not, write to the Free Software
    19 ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
    20 ;; 02111-1307, USA.
    21 
    22 ;;; Commentary:
    23 
    24 ;; This is the user API to the Prometheus object system.
    25 
    26 ;; We provide value slots which only return a value, and an
    27 ;; infrastructure for setters for value, method and parent slots.
    28 ;; Especially the setters for value slots are much more efficient than
    29 ;; DELETE-SLOT! + ADD-SLOT!, as they use shared store.
    30 
    31 ;; See the Prometheus manual for more information.
    32 
    33 ;;; Code:
    34 
    35 
    36 (require-library srfi-1)
    37 
    38 
    39 (module prometheus-internal (make-prometheus-internal-root-object)
    40 
    41   (import scheme chicken srfi-1)
    42 
    43 ;;;;;;;;;;;;;;;;;;;
    44 ;;; Root Object ;;;
    45 ;;;;;;;;;;;;;;;;;;;
    46 
    47 ;; This creates a root object which only provides the bare-bones
    48 ;; interface of the prometheus-internal.
    49 
    50 (define (make-prometheus-internal-root-object)
    51   (let ((obj (make-prometheus-object)))
    52     (for-each (lambda (entry)
    53                 (add-slot! obj #f (car entry) (cadr entry)))
    54               `((add-slot!        ,add-slot!)
    55                 (delete-slot!     ,delete-slot!)
    56                 (clone            ,clone)
    57                 (message-not-understood ,message-not-understood)
    58                 (ambiguous-message-send ,ambiguous-message-send)))
    59     obj))
    60 
    61 ;;;;;;;;;;;;;;;;
    62 ;;; Messages ;;;
    63 ;;;;;;;;;;;;;;;;
    64 
    65 ;;; @deffn Message clone
    66 ;;;
    67 ;;; Return a clone of the message recipient. This creates a new object
    68 ;;; with a single slot, @defvar{parent}, which points to the cloned
    69 ;;; object.
    70 ;;; @end deffn
    71 (define (clone self resend)
    72   (let ((new (make-prometheus-object)))
    73     (add-slot! new #f 'parent self #t)
    74     new))
    75 
    76 ;;; @deffn Message add-slot! name proc [parent?]
    77 ;;;
    78 ;;; Add a method to the recipient. Sending the object a @var{name}
    79 ;;; message now invokes @var{proc} with the same arguments in addition
    80 ;;; to a @var{self} argument pointing to the current object and a
    81 ;;; @var{resend} procedure available to resend the message if the
    82 ;;; method does not want to handle it directly.
    83 ;;; @end deffn
    84 (define (add-slot! self resend name proc . rest)
    85   ;; FIXME! Maybe at one point do a type check of PROC?
    86   (let ((parent? (if (null? rest)
    87                      #f
    88                      (car rest))))
    89     (if (not parent?)
    90         (obj-add-slot! self name proc #f)
    91         (obj-add-slot! self
    92                        name
    93                        (lambda (self resend)
    94                          proc)
    95                        proc))))
    96 
    97 ;;; @deffn Message delete-slot! name
    98 ;;;
    99 ;;; Delete the slot @var{name} from the receiving object. Beware that
    100 ;;; parents might contain the same slot, so a message send can still
    101 ;;; succeed even after a slot is deleted.
    102 ;;; @end deffn
    103 (define (delete-slot! self resend name)
    104   (obj-delete-slot! self name))
    105 
    106 ;;; @deffn message-not-understood message args
    107 ;;;
    108 ;;; This is received when the message @var{message} with arguments
    109 ;;; @var{args} to the object was not understood.
    110 ;;; The root object just signals an error.
    111 ;;; @end deffn
    112 (define (message-not-understood self resend message args)
    113   (error "Message not understood" self message args))
    114 
    115 ;;; @deffn ambiguous-message-send message args
    116 ;;;
    117 ;;; This is received when the message @var{message} with arguments
    118 ;;; @var{args} to the object would have reached multiple parents.
    119 ;;; The root object just signals an error.
    120 ;;; @end deffn
    121 (define (ambiguous-message-send self resend message args)
    122   (error "Ambiguous message send" self message args))
    123 
    124 
    125 ;;;;;;;;;;;;;;;;;;;
    126 ;;; Object Data ;;;
    127 ;;;;;;;;;;;;;;;;;;;
    128 
    129 ;; Object data stores the data in each object. We retrieve this data
    130 ;; with a special private message, and then can operate on it. It
    131 ;; would not be necessary to store the parent list separately, but we
    132 ;; do that for speed reasons.
    133 
    134 (define-record-type prometheus-data
    135   (make-prometheus-data slots parents)
    136   prometheus-data?
    137   (slots prometheus-data-slots
    138          set-prometheus-data-slots!)
    139   (parents prometheus-data-parents
    140            set-prometheus-data-parents!))
    141 
    142 ;; We don't check for duplicates in this code for speed reasons. The
    143 ;; code that uses these procedures should take care of ensuring that
    144 ;; no duplicates are added.
    145 
    146 (define (data-add-parent! data name parent)
    147   (set-prometheus-data-parents! data
    148                                 (cons (cons name parent)
    149                                       (prometheus-data-parents data)))
    150   (values))
    151 
    152 (define (data-delete-parent! data name)
    153   (set-prometheus-data-parents! data
    154                                 (alist-delete! name
    155                                                (prometheus-data-parents data)
    156                                                eq?))
    157   (values))
    158 
    159 (define (data-get-slot data name)
    160   (assq name (prometheus-data-slots data)))
    161 
    162 (define (data-add-slot! data name slot)
    163   (set-prometheus-data-slots! data
    164                               (cons (cons name slot)
    165                                     (prometheus-data-slots data)))
    166   (values))
    167 
    168 (define (data-delete-slot! data name)
    169   (set-prometheus-data-slots! data
    170                               (alist-delete! name
    171                                              (prometheus-data-slots data)))
    172   (values))
    173 
    174 ;;;;;;;;;;;;;;;;;;;;
    175 ;;; Object Slots ;;;
    176 ;;;;;;;;;;;;;;;;;;;;
    177 
    178 ;; This record type stores the information about the slots within an
    179 ;; object. The handler is just the procedure to be called when the
    180 ;; message is received; the parent is true only if this slot is a
    181 ;; parent, and then this is the parent object. This way, we can avoid
    182 ;; calling the handler again to retrieve it.
    183 
    184 (define-record-type prometheus-slot
    185   (make-prometheus-slot handler parent)
    186   prometheus-slot?
    187   (handler prometheus-slot-handler)
    188   (parent prometheus-slot-parent))
    189 
    190 
    191 ;;; This is the internal message sent to the object to retrieve the
    192 ;;; data. Since this is a list, it can't be faked from outside the
    193 ;;; module.
    194 (define *prometheus-get-data-message* (list '*prometheus-get-data-message*))
    195 
    196 (define (make-prometheus-object)
    197   (let* ((data (make-prometheus-data '() '()))
    198          (self #f)
    199          (obj (lambda (message . args)
    200                 (if (eq? message *prometheus-get-data-message*)
    201                     data
    202                     (send self message args)))))
    203     (set! self obj)
    204     obj))
    205 
    206 (define (prometheus-object-data obj)
    207   (obj *prometheus-get-data-message*))
    208 
    209 (define (obj-add-slot! obj name handler parent)
    210   (let ((new-slot (make-prometheus-slot handler parent))
    211         (data (prometheus-object-data obj)))
    212     (cond
    213      ((data-get-slot data name)
    214       => (lambda (entry)
    215            (if (prometheus-slot-parent (cdr entry))
    216                (data-delete-parent! obj name))
    217            (if parent
    218                (data-add-parent! data name parent))
    219            (set-cdr! entry new-slot)))
    220      (else
    221       (data-add-slot! data name new-slot)
    222       (if parent
    223           (data-add-parent! data name parent)))))
    224   (values))
    225 
    226 (define (obj-delete-slot! obj name)
    227   (let ((data (prometheus-object-data obj)))
    228     (cond
    229      ((data-get-slot data name)
    230       => (lambda (entry)
    231            (data-delete-slot! data name)
    232            (if (prometheus-slot-parent (cdr entry))
    233                (data-delete-parent! data name))))))
    234   (values))
    235 
    236 ;;;;;;;;;;;;;;;;;;;;;;;
    237 ;;; Message Sending ;;;
    238 ;;;;;;;;;;;;;;;;;;;;;;;
    239 
    240 ;; PROC is a handler for the message ARGS in MESSAGE-HOLDER, where the
    241 ;; message was originally sent to OBJ. Evaluate this message,
    242 ;; providing the resend procedure.
    243 (define (eval-message obj message-holder proc args)
    244   (apply proc
    245          obj
    246          (lambda (parent message . args)
    247            (cond
    248             ((eq? parent #f)
    249              (undirected-resend obj message-holder message args))
    250             ((eq? parent #t)
    251              (undirected-local-resend obj message-holder message args))
    252             (else
    253              (directed-resend obj message-holder parent message args))))
    254          args))
    255 
    256 
    257 ;; Inputs: rec  - the receiver of the message
    258 ;;         sel  - the message selector
    259 ;;         args - the actual arguments
    260 ;; Output: res  - the result object
    261 ;;
    262 ;; send (rec, sel, args) {
    263 ;;   M <- lookup(rec, sel, '())
    264 ;;   if |M| = 0: error: message-not-understood
    265 ;;      |M| = 1: res <- eval(rec, M, args)
    266 ;;      |M| > 1: error: ambiguous-message-send
    267 ;;   return res
    268 ;; }
    269 (define (send obj message args)
    270   (send-with-receiver obj obj #f message args))
    271 
    272 ;; Inputs: rec  - the receiver of the message
    273 ;;         smh  - the sending method holder
    274 ;;         sel  - the message selector
    275 ;;         args - the actual arguments
    276 ;; Output: res  - the result object
    277 ;;
    278 ;; undirected_resend (rec, smh, sel, args) {
    279 ;;   M <- parent_lookup(smh, sel '())
    280 ;;   if |M| = 0: error: message-not-understood
    281 ;;      |M| = 1: res <- eval(rec, M, args)
    282 ;;      |M| > 1: error: ambiguous-message-send
    283 ;;   end
    284 ;;   return res
    285 ;; }
    286 (define (undirected-resend obj old-message-holder message args)
    287   (send-with-receiver obj old-message-holder #t message args))
    288 
    289 ;; This is the same as UNDIRECTED-RESEND, but it starts searching in
    290 ;; the current object.
    291 (define (undirected-local-resend obj old-message-holder message args)
    292   (send-with-receiver obj old-message-holder #f message args))
    293 
    294 
    295 ;; Inputs: rec - the receiver of the message
    296 ;;         smh - the sending method holder
    297 ;;         del - the name of the delegatee
    298 ;;         sel - the message selector
    299 ;; Output: res - the result object
    300 ;;
    301 ;; directed_resend (rec, smh, del, sel, args) {
    302 ;;   D <- { s \in smh | s.name = del }
    303 ;;   if |D| = 0
    304 ;;   then
    305 ;;     error: missing-delegatee
    306 ;;   fi
    307 ;;   M <- lookup(smh.del, sel, '())
    308 ;;   if |M| = 0: error: message-not-understood
    309 ;;      |M| = 1: res <- eval(rec, M, args)
    310 ;;      |M| > 1: error: ambiguous-message-send
    311 ;;   end
    312 ;;   return res
    313 ;; }
    314 (define (directed-resend obj old-message-holder parent message args)
    315   (send-with-receiver obj
    316                       (send-with-receiver old-message-holder
    317                                           old-message-holder
    318                                           #f
    319                                           parent
    320                                           '())
    321                       #f
    322                       message
    323                       args))
    324 
    325 ;; Send the MESSAGE with ARGS to RECEIVER, but start with lookup only
    326 ;; in LOOKUP-OBJ, or in its parents when START-WITH-PARENTS? is true.
    327 (define (send-with-receiver receiver lookup-obj start-with-parents?
    328                             message args)
    329   (receive (proc message-holder error-name)
    330       (if start-with-parents?
    331           (parent-lookup lookup-obj message '())
    332           (lookup lookup-obj message '()))
    333     (if (not error-name)
    334         (eval-message receiver message-holder proc args)
    335         (case error-name
    336           ((message-not-understood)
    337            (if (eq? message 'message-not-understood)
    338                (error "No message not understood handler" receiver message args)
    339                (receiver 'message-not-understood message args)))
    340           ((ambiguous-message-send)
    341            (if (eq? message 'ambiguous-message-send)
    342                (error "No ambiguous message send handler" receiver message args)
    343                (receiver 'ambiguous-message-send message args)))
    344           (else
    345            (error "Unknown error" error-name receiver message args))))))
    346 
    347 ;; Inputs: obj - the object being searched
    348 ;;         sel - the message selector
    349 ;;         V   - visited objects
    350 ;; Output: M   - set of matching slots
    351 ;;
    352 ;; lookup (obj, sel, V) {
    353 ;;   if obj \in V
    354 ;;   then
    355 ;;     res <- '()
    356 ;;   else
    357 ;;     M <- { s \in obj | s.name = sel }
    358 ;;     if M = '()
    359 ;;     then
    360 ;;        M <- parent_lookup(obj, sel, V)
    361 ;;     end
    362 ;;   end
    363 ;;   return M
    364 ;; }
    365 (define (lookup obj message visited)
    366   ;; We use ASSQ for the cycle detection, as ASSQ is a primitive in
    367   ;; Scheme 48 as compared to MEMQ. This increases speed measurably.
    368   (cond
    369    ((assq obj visited)
    370     (values #f #f 'message-not-understood))
    371    ((lookup-immediate obj message)
    372     => (lambda (value)
    373          (values value obj #f)))
    374    (else
    375     (parent-lookup obj message visited))))
    376 
    377 (define (lookup-immediate obj message)
    378   (cond
    379    ((data-get-slot (prometheus-object-data obj)
    380                    message)
    381     => (lambda (entry)
    382          (prometheus-slot-handler (cdr entry))))
    383    (else
    384     #f)))
    385 
    386 ;; parent_lookup (obj, sel, V) {
    387 ;;   P <- { s \in obj | s.isParent }
    388 ;;   M <- \union_{s \in P} lookup(s.contents, sel, V \union { obj })
    389 ;; }
    390 (define (parent-lookup obj message old-visited)
    391   (let ((visited (cons (list obj) old-visited)))
    392     (let loop ((lis (prometheus-data-parents (prometheus-object-data obj)))
    393                (message-holder #f)
    394                (value #f))
    395       (if (null? lis)
    396           (if message-holder
    397               (values value message-holder #f)
    398               (values #f #f 'message-not-understood))
    399           (receive (proc this-message-holder error)
    400               (lookup (cdar lis) message visited)
    401             (cond
    402              ((and message-holder
    403                    this-message-holder
    404                    (not (eq? message-holder this-message-holder)))
    405               (values #f #f 'ambiguous-message-send))
    406              (this-message-holder
    407               (loop (cdr lis)
    408                     this-message-holder
    409                     proc))
    410              (else
    411               (loop (cdr lis)
    412                     message-holder
    413                     value))))))))
    414 )
    415 
    416 (module prometheus (make-prometheus-root-object
    417                     *the-root-object*
    418                     define-method
    419                     define-object define-object/add-slots!)
    420 
    421   (import scheme chicken prometheus-internal srfi-1)
    422 
    423 ;; Our private slot message to access the slot list.
    424 (define *prometheus-mutate-slots-message*
    425   (list '*prometheus-mutate-slots-message*))
    426 
    427 ;; We keep a local list of slots so we can access them later (for
    428 ;; introspection), and to mutate slots which are shared between
    429 ;; setters and getters.
    430 (define-record-type prometheus-mutable-slot
    431   (make-prometheus-mutable-slot getter setter value type)
    432   prometheus-mutable-slot?
    433   (getter slot-getter set-slot-getter!)
    434   (setter slot-setter set-slot-setter!)
    435   (value  slot-value  set-slot-value!)
    436   (type   slot-type))
    437 
    438 ;;; @deffn Message clone
    439 ;;;
    440 ;;; Return a clone of the message recipient. This creates a new object
    441 ;;; with a single slot, @var{parent}, which points to the cloned
    442 ;;; object.
    443 ;;; @end deffn
    444 (define (clone self resend)
    445   (let ((new-obj (resend #f 'clone))
    446         (slots '()))
    447     (new-obj 'add-method-slot! *prometheus-mutate-slots-message*
    448              (lambda (self resend proc)
    449                (set! slots (proc slots))))
    450     new-obj))
    451 
    452 ;;; @deffn Message add-value-slot! getter value
    453 ;;; @deffnx Message add-value-slot! getter setter value
    454 ;;;
    455 ;;; Add a new value slot to the recipient. The value of the slot can
    456 ;;; be retrieved with the @var{getter} message. If a @var{setter} is
    457 ;;; given, that message can be used to change the value of the slot.
    458 ;;; @end deffn
    459 (define add-value-slot!
    460   (case-lambda
    461    ((self resend getter value)
    462     (let ((slot (make-prometheus-mutable-slot getter #f value 'value)))
    463       (self 'delete-slot! getter)
    464       (add-mutable-slot! self getter slot)
    465       (resend #f 'add-slot! getter (lambda (self resend)
    466                                      value))))
    467    ((self resend getter setter value)
    468     (let ((slot (make-prometheus-mutable-slot getter setter value 'value)))
    469       (self 'delete-slot! getter)
    470       (self 'delete-slot! setter)
    471       (add-mutable-slot! self getter slot)
    472       (resend #f 'add-slot! getter
    473               (lambda (self resend)
    474                 (slot-value slot)))
    475       (resend #f 'add-slot! setter
    476               (lambda (new-self resend new-value)
    477                 (if (eq? new-self self)
    478                     (set-slot-value! slot new-value)
    479                     (new-self 'add-value-slot! getter setter new-value))))))))
    480 
    481 ;;; @deffn Message add-method-slot! getter proc
    482 ;;; @deffnx Message add-method-slot! getter setter proc
    483 ;;;
    484 ;;; Add a method to the recipient. Sending the object a @var{getter}
    485 ;;; message now invokes @var{proc} with the same arguments in addition
    486 ;;; to a @var{self} argument pointing to the current object and a
    487 ;;; @var{resend} procedure available to resend the message if the
    488 ;;; method does not want to handle it directly.
    489 ;;;
    490 ;;; The @var{setter} message can later be used to change the
    491 ;;; procedure.
    492 ;;; @end deffn
    493 (define add-method-slot!
    494   (case-lambda
    495    ((self resend getter value)
    496     (let ((slot (make-prometheus-mutable-slot getter #f value 'method)))
    497       (self 'delete-slot! getter)
    498       (add-mutable-slot! self getter slot)
    499       (resend #f 'add-slot! getter value)))
    500    ((self resend getter setter value)
    501     (let ((slot (make-prometheus-mutable-slot getter setter value 'method)))
    502       (self 'delete-slot! getter)
    503       (self 'delete-slot! setter)
    504       (add-mutable-slot! self getter slot)
    505       (resend #f 'add-slot! getter value)
    506       (resend #f 'add-slot! setter
    507               (lambda (new-self resend new-value)
    508                 (new-self 'add-method-slot! getter new-value)))))))
    509 
    510 ;;; @deffn Message add-parent-slot! getter parent
    511 ;;; @deffnx Message add-parent-slot! getter setter parent
    512 ;;;
    513 ;;; Add a parent slot to the recipient. Parent slots are searched for
    514 ;;; slots not found directly in the object. The @var{setter} message,
    515 ;;; if given, can be used to later change the value of the parent
    516 ;;; slot.
    517 ;;; @end deffn
    518 (define add-parent-slot!
    519   (case-lambda
    520    ((self resend getter value)
    521     (let ((slot (make-prometheus-mutable-slot getter #f value 'parent)))
    522       (self 'delete-slot! getter)
    523       (add-mutable-slot! self getter slot)
    524       (resend #f 'add-slot! getter value #t)))
    525    ((self resend getter setter value)
    526     (let ((slot (make-prometheus-mutable-slot getter setter value 'parent)))
    527       (self 'delete-slot! getter)
    528       (self 'delete-slot! setter)
    529       (add-mutable-slot! self getter slot)
    530       (resend #f 'add-slot! getter value #t)
    531       (resend #f 'add-slot! setter
    532               (lambda (self resend value)
    533                 (self 'add-parent-slot! getter value))
    534               #f)))))
    535 
    536 ;;; @deffn Message delete-slot! getter
    537 ;;;
    538 ;;; Delete the slot named @var{getter} from the receiving object. This
    539 ;;; also removes the setter corresponding to @var{getter}, if any.
    540 ;;; Beware that the parents might contain the same slot, so a message
    541 ;;; send can still succeed even after a slot is deleted.
    542 ;;; @end deffn
    543 (define (delete-slot! self resend getter)
    544   (delete-mutable-slot! self  getter)
    545   (resend #f 'delete-slot! getter))
    546 
    547 ;;; Add to the local list. A mutable slot is the slot shared between a
    548 ;;; getter and the setter.
    549 ;;; If already there, remove getter and setter
    550 (define (add-mutable-slot! obj name slot)
    551   (delete-mutable-slot! obj name)
    552   (obj *prometheus-mutate-slots-message*
    553        (lambda (old)
    554          (cons slot old))))
    555 
    556 ;;; Delete from the local list
    557 ;;; - If it's a getter, remove setter
    558 ;;; - If it's a setter, make setter slot #f
    559 (define (delete-mutable-slot! obj name)
    560   (obj *prometheus-mutate-slots-message*
    561        (lambda (old)
    562          (filter (lambda (slot)
    563                    (if (eq? name (slot-setter slot))
    564                        (set-slot-setter! slot #f))
    565                    (if (eq? name (slot-getter slot))
    566                        (begin
    567                          (if (slot-setter slot)
    568                              (obj 'delete-slot! (slot-setter slot)))
    569                          #f)
    570                        #t))
    571                  old))))
    572 
    573 ;;; @deffn Message slots->list
    574 ;;;
    575 ;;; This message returns a list of slots in this object. The elements
    576 ;;; of the list are lists with four elements, @var{getter-name},
    577 ;;; @var{setter-name} or @code{#f}, @var{value} and @var{type}, where
    578 ;;; @var{type} can be @code{value}, @code{method} or @code{parent}.
    579 ;;; @end deffn
    580 (define (slots->list self resend)
    581   (let ((slots #f))
    582     (self *prometheus-mutate-slots-message*
    583           (lambda (obj-slots)
    584             (set! slots obj-slots)
    585             obj-slots))
    586     (map (lambda (slot)
    587            (list (slot-getter slot)
    588                  (slot-setter slot)
    589                  (slot-value slot)
    590                  (slot-type slot)))
    591          slots)))
    592 
    593 ;; We also provide an ADD-SLOT! message which overwrites the ADD-SLOT!
    594 ;; message used by prometheus-internal.
    595 (define (add-slot! self resend . args)
    596   (self 'message-not-understood 'add-slot! args))
    597 
    598 ;;; @deffn Syntax define-method (obj 'message self resend . args) body @dots{}
    599 ;;;
    600 ;;; This is syntactic sugar for the often-used idiom to define a
    601 ;;; method slot, by sending a @code{add-method-slot!} message with a
    602 ;;; @var{message} name and a lambda form with @var{self}, @var{resend}
    603 ;;; and @var{args} formals, and a @var{body}.
    604 ;;; @end deffn
    605 (define-syntax define-method
    606   (syntax-rules ()
    607     ((_ (obj 'message self resend . args)
    608         body ...)
    609      (obj 'add-method-slot!
    610           'message
    611           (lambda (self resend . args)
    612             body ...)))))
    613 
    614 (define-syntax define-object/add-slots!
    615   (syntax-rules ()
    616     ((_ o)
    617      (values))
    618     ((_ o ((method-name . method-args) body ...)
    619         slots ...)
    620      (begin
    621        (o 'add-method-slot! 'method-name (lambda method-args
    622                                            body ...))
    623        (define-object/add-slots! o slots ...)))
    624     ((_ o (slot-getter slot-setter slot-value)
    625         slots ...)
    626      (begin
    627        (o 'add-value-slot! 'slot-getter 'slot-setter slot-value)
    628        (define-object/add-slots! o slots ...)))
    629     ((_ o (slot-getter slot-value)
    630         slots ...)
    631      (begin
    632        (o 'add-value-slot! 'slot-getter slot-value)
    633        (define-object/add-slots! o slots ...)))))
    634 
    635 ;;; @deffn Syntax define-object name (parent other-parents @dots{}) slots @dots{}
    636 ;;;
    637 ;;; This is syntactic sugar for the typical actions of cloning an
    638 ;;; object from a @var{parent} object, and adding more slots.
    639 ;;;
    640 ;;; @var{other-parents} is a list of @code{(name object)} lists, where
    641 ;;; each @var{object} is added as a parent slot named @var{name}.
    642 ;;;
    643 ;;; @var{slots} is a list of slot specifications, either @code{(getter
    644 ;;; value)} or @code{(getter setter value)} for value slots, or
    645 ;;; @code{((name self resend args @dots{}) body @dots{})} for method
    646 ;;; slots.
    647 ;;; @end deffn
    648 (define-syntax define-object
    649   (syntax-rules ()
    650     ((_ name (creation-parent (parent-name parent-object) ...)
    651         slots ...)
    652      (define name (let ((o (creation-parent 'clone)))
    653                     (o 'add-parent-slot! 'parent-name parent-object)
    654                     ...
    655                     (define-object/add-slots! o slots ...)
    656                     o)))))
    657 
    658 ;;; @deffn Procedure make-prometheus-root-object
    659 ;;;
    660 ;;; This creates a new root object from which other objects can
    661 ;;; cloned. This object is independent of any other objects, and thus
    662 ;;; creates a new inheritance tree.
    663 ;;; @end deffn
    664 (define (make-prometheus-root-object)
    665   (let ((obj ((make-prometheus-internal-root-object) 'clone))
    666         (slots '()))
    667     (obj 'add-slot!
    668          *prometheus-mutate-slots-message*
    669          (lambda (self resend proc)
    670            (set! slots (proc slots))))
    671     (obj 'add-slot! 'add-method-slot! add-method-slot!)
    672     (for-each (lambda (entry)
    673                 (obj 'add-method-slot! (car entry) (cadr entry)))
    674               `((add-method-slot! ,add-method-slot!)
    675                 (clone ,clone)
    676                 (add-value-slot! ,add-value-slot!)
    677                 (add-parent-slot! ,add-parent-slot!)
    678                 (delete-slot! ,delete-slot!)
    679                 (add-slot! ,add-slot!)
    680                 (slots->list ,slots->list)))
    681     obj))
    682 
    683 ;;; @deffn Variable *the-root-object*
    684 ;;;
    685 ;;; This is the default root object. If not really intended otherwise,
    686 ;;; this should be used as the root of other object hierarchies.
    687 ;;; @end deffn
    688 (define *the-root-object* (make-prometheus-root-object))
    689 
    690 )
     15(include "prometheus-2/scheme/packages.scm")
  • release/4/prometheus/prometheus.setup

    r12594 r14451  
    1 (compile prometheus.scm -s -O2 -d1 -j prometheus -j prometheus-internal)
     1(compile prometheus.scm -s -O2 -d1 -j _prometheus -j _hermes -j hermes)
     2(compile _prometheus.import.scm -s -O2 -d0)
     3(compile _hermes.import.scm -s -O2 -d0)
     4(compile hermes.import.scm -s -O2 -d0)
    25(compile prometheus.import.scm -s -O2 -d0)
    3 (compile prometheus-internal.import.scm -s -O2 -d0)
     6
    47(install-extension
    58 'prometheus
    6  '("prometheus.so" "prometheus.import.so" "prometheus-internal.import.so")
    7  '((version 1.1)
     9 '("prometheus.so" "prometheus.import.so" "_prometheus.import.so" "_hermes.import.so" "hermes.import.so")
     10 '((version 2.0)
    811   (documentation
    9     "prometheus.html"
    10     "prometheus-manual.html") ) )
     12    "prometheus.html")))
Note: See TracChangeset for help on using the changeset viewer.