Changeset 2542 in project


Ignore:
Timestamp:
11/29/06 12:35:29 (15 years ago)
Author:
Thomas Chust
Message:

modds: Slot update tweaks and partial native support for hygienic macros

  • Slot updates now are more efficient due to the use of hashtable-update!
  • New macros for incrementing and decrementing slots have been added.
  • Due to fundamental problems of hygienic macros, define-generic has to remain a low level macro, but everything else is defined using syntax-rules when hygienic macros are available.
Location:
modds
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • modds/modds-base.scm

    r2533 r2542  
    22;;;; Multiple object dynamic dispatch prototype based object system
    33
    4 (require-extension (srfi 1) (srfi 17) (srfi 26) (srfi 69) lolevel)
     4(require-extension (srfi 1) (srfi 9) (srfi 17) (srfi 26) (srfi 69) lolevel)
    55
    66(define-extension modds-base
     
    88   object object?
    99   prototype prototype-set!
    10    slot-ref slot-set! remove-slot!
     10   slot-ref slot-set! slot-update! remove-slot!
    1111   push-method-for-role! drop-method-for-role!
    1212   methods-for-role call-method
     
    6565;;; object record type and accessors
    6666
    67 (define-record object
    68   prototype slots roles)
     67(define-record-type object
     68  (make-object prototype slots roles)
     69  object?
     70  (prototype object-prototype object-prototype-set!)
     71  (slots object-slots)
     72  (roles object-roles))
    6973
    7074(define prototype-set!
     
    186190   slot-set!))
    187191
     192(define (slot-update! obj name proc)
     193  (hash-table-update!
     194   (object-slots obj) name proc
     195   (lambda ()
     196     (let ((proto (object-prototype obj)))
     197       (if proto
     198           (slot-ref proto name)
     199           (error 'slot-update! "no such slot" name))))))
     200
    188201(define (remove-slot! obj name)
    189202  (hash-table-delete! (object-slots obj) name))
  • modds/modds-demo.scm

    r2533 r2542  
    5858 (inside? '#,(object <rect> (x 2) (y 3) (width 1) (height 1)) r))
    5959(print
    60  (inside? '#,(object <rect> (x 8) (y 8) (width 1) (height 1)) r))
     60 (inside?
     61  (let ((r1 '#,(object <rect> (x 8) (y 8))))
     62    (++> r1 width)
     63    (++> r1 height)
     64    r1)
     65  r))
    6166(print
    6267 (inside? (resize (make <rect> x: 2 y: 3) 10) r))
  • modds/modds-doc.scm

    r2534 r2542  
    1313     (author (url "http://www.chust.org/" "Thomas Chust"))
    1414     (history
     15      (version "1.1.2" "Partial native support of hygienic macros")
     16      (version "1.1.1" "Some slot update tweaks")
    1517      (version "1.1.0" "Added support for optional and keyword arguments")
    1618      (version "1.0.0" "First attempt"))
     
    5557        (macro
    5658         "(~> (object <object>) (slot <symbol>) (proc <procedure>)) => <void>"
    57          (p "Sets the slot specified by the symbol " (tt "slot") " in the object " (tt "object") " to the value obtained by applying " (tt "proc") " to its current value. The slot name is automatically quoted."))
     59         (p "Updates the slot specified by the symbol " (tt "slot") " in the object " (tt "object") " to the value obtained by applying " (tt "proc") " to its current value. The slot name is automatically quoted.")
     60         (p "Equivalent to " (tt "(=> object slot (proc (-> object slot)))") " but more efficient."))
     61        (definition
     62          (signatures
     63           (signature
     64            "macro" "(++> (object <object>) (slot <symbol>)) => <number>")
     65           (signature
     66            "macro" "(>++ (object <object>) (slot <symbol>)) => <number>"))
     67          (p "Pre- or post-increments the slot specified by the symbol " (tt "slot") " in the object " (tt "object") " and returns its value after or before the increment. The slot name is automatically quoted."))
     68        (definition
     69          (signatures
     70           (signature
     71            "macro" "(--> (object <object>) (slot <symbol>)) => <number>")
     72           (signature
     73            "macro" "(>-- (object <object>) (slot <symbol>)) => <number>"))
     74          (p "Pre- or post-decrements the slot specified by the symbol " (tt "slot") " in the object " (tt "object") " and returns its value after or before the increment. The slot name is automatically quoted."))
    5875        (macro
    5976         "(define-generic (name <symbol>)) => <void>"
     
    106123           (signature "setter" "(set! (slot-ref (object <object>) (name <symbol>)) (value <root>)) => <void>"))
    107124          (p "Retrieves or sets the value of a slot in the given object record. Primitive values have no slots that could be set or retrieved."))
     125        (procedure
     126         "(slot-update! (object <object>) (name <symbol>) (proc <procedure>)) => <void>"
     127         (p "Updates a slot in the given object to the value obtained by applying " (tt "proc") " to its current value.")
     128         (p "Equivalent to " (tt "(slot-set! object name (proc (slot-ref object name)))") " but more efficient."))
    108129        (procedure
    109130         "(remove-slot! (object <object>) (name <symbol>)) => <boolean>"
  • modds/modds.html

    r2534 r2542  
    158158<h3>Version</h3>
    159159<ul>
     160<li>1.1.2 Partial native support of hygienic macros</li>
     161<li>1.1.1 Some slot update tweaks</li>
    160162<li>1.1.0 Added support for optional and keyword arguments</li>
    161163<li>1.0.0 First attempt</li></ul></div>
     
    195197<dt class="definition"><strong>macro:</strong> (~&gt; (object &lt;object&gt;) (slot &lt;symbol&gt;) (proc &lt;procedure&gt;)) =&gt; &lt;void&gt;</dt>
    196198<dd>
    197 <p>Sets the slot specified by the symbol <tt>slot</tt> in the object <tt>object</tt> to the value obtained by applying <tt>proc</tt> to its current value. The slot name is automatically quoted.</p></dd>
     199<p>Updates the slot specified by the symbol <tt>slot</tt> in the object <tt>object</tt> to the value obtained by applying <tt>proc</tt> to its current value. The slot name is automatically quoted.</p>
     200<p>Equivalent to <tt>(=&gt; object slot (proc (-&gt; object slot)))</tt> but more efficient.</p></dd>
     201<dt class="definition"><strong>macro:</strong> (++&gt; (object &lt;object&gt;) (slot &lt;symbol&gt;)) =&gt; &lt;number&gt;
     202<br /><strong>macro:</strong> (&gt;++ (object &lt;object&gt;) (slot &lt;symbol&gt;)) =&gt; &lt;number&gt;</dt>
     203<dd>
     204<p>Pre- or post-increments the slot specified by the symbol <tt>slot</tt> in the object <tt>object</tt> and returns its value after or before the increment. The slot name is automatically quoted.</p></dd>
     205<dt class="definition"><strong>macro:</strong> (--&gt; (object &lt;object&gt;) (slot &lt;symbol&gt;)) =&gt; &lt;number&gt;
     206<br /><strong>macro:</strong> (&gt;-- (object &lt;object&gt;) (slot &lt;symbol&gt;)) =&gt; &lt;number&gt;</dt>
     207<dd>
     208<p>Pre- or post-decrements the slot specified by the symbol <tt>slot</tt> in the object <tt>object</tt> and returns its value after or before the increment. The slot name is automatically quoted.</p></dd>
    198209<dt class="definition"><strong>macro:</strong> (define-generic (name &lt;symbol&gt;)) =&gt; &lt;void&gt;</dt>
    199210<dd>
     
    235246<dd>
    236247<p>Retrieves or sets the value of a slot in the given object record. Primitive values have no slots that could be set or retrieved.</p></dd>
     248<dt class="definition"><strong>procedure:</strong> (slot-update! (object &lt;object&gt;) (name &lt;symbol&gt;) (proc &lt;procedure&gt;)) =&gt; &lt;void&gt;</dt>
     249<dd>
     250<p>Updates a slot in the given object to the value obtained by applying <tt>proc</tt> to its current value.</p>
     251<p>Equivalent to <tt>(slot-set! object name (proc (slot-ref object name)))</tt> but more efficient.</p></dd>
    237252<dt class="definition"><strong>procedure:</strong> (remove-slot! (object &lt;object&gt;) (name &lt;symbol&gt;)) =&gt; &lt;boolean&gt;</dt>
    238253<dd>
     
    365380 (inside? <font color="#DA70D6"><b>'</b></font><font color="#DA70D6"><b>#,</b></font>(object <font color="#228B22"><b>&lt;rect&gt;</b></font> (x 2) (y 3) (width 1) (height 1)) r))
    366381(print
    367  (inside? <font color="#DA70D6"><b>'</b></font><font color="#DA70D6"><b>#,</b></font>(object <font color="#228B22"><b>&lt;rect&gt;</b></font> (x 8) (y 8) (width 1) (height 1)) r))
     382 (inside?
     383  (<b><font color="#A020F0">let</font></b> ((r1 <font color="#DA70D6"><b>'</b></font><font color="#DA70D6"><b>#,</b></font>(object <font color="#228B22"><b>&lt;rect&gt;</b></font> (x 8) (y 8))))
     384    (<b><font color="#A020F0">++&gt;</font></b> r1 width)
     385    (<b><font color="#A020F0">++&gt;</font></b> r1 height)
     386    r1)
     387  r))
    368388(print
    369389 (inside? (resize (make <font color="#228B22"><b>&lt;rect&gt;</b></font> <b><font color="#5F9EA0">x:</font></b> 2 <b><font color="#5F9EA0">y:</font></b> 3) 10) r))
  • modds/modds.scm

    r2533 r2542  
    44(require-extension (srfi 10) (srfi 17))
    55
    6 (define-extension modds)
    7 
    86;;; method definition syntax
    97
    10 (define-macro (define-generic name)
    11   `(define (,name . objs)
    12      (call-method ',name objs)))
     8(cond-expand
     9 (hygienic-macros
     10  (define-syntax define-generic
     11    (syntax-rules ()
     12      ((define-generic name)
     13       (define (name . objs)
     14         (call-method 'name objs))))))
     15 (else
     16  (define-macro (define-generic name)
     17    `(define (,name . objs)
     18       (call-method ',name objs)))))
    1319
    1420(define-macro (define-method spec . exprs)
     
    8288;;; object definition syntax
    8389
    84 (define-macro (define-object spec . slots)
    85   (let* ((name (if (list? spec) (car spec) spec))
    86          (buf (gensym name))
    87          (proto (if (list? spec) (cadr spec) '<object>)))
    88     `(define ,name
    89        (let ((,buf (object ,proto ,@(map (lambda (spec)
    90                                            (if (list? spec)
    91                                                `(list ',(car spec) ,@(cdr spec))
    92                                                (list 'quote spec)))
    93                                          slots))))
    94          (slot-set! ,buf 'name ',name)
    95          ,buf))))
     90(cond-expand
     91 (hygienic-macros
     92  (define-syntax define-object
     93    (syntax-rules ()
     94      ((define-object (symbol proto) slots ...)
     95       (define symbol
     96         (let-syntax ((slot-spec (syntax-rules ()
     97                                   ((slot-spec (symbol value))
     98                                    (list 'symbol value))
     99                                   ((slot-spec symbol)
     100                                    'symbol))))
     101           (let ((obj (object proto (slot-spec slots) ...)))
     102             (slot-set! obj 'name 'symbol)
     103             obj))))
     104      ((define-object symbol slots ...)
     105       (define-object (symbol <object>) slots ...)))))
     106 (else
     107  (define-macro (define-object spec . slots)
     108    (let* ((name (if (list? spec) (car spec) spec))
     109           (buf (gensym name))
     110           (proto (if (list? spec) (cadr spec) '<object>)))
     111      `(define ,name
     112         (let ((,buf (object ,proto ,@(map (lambda (spec)
     113                                             (if (list? spec)
     114                                                 `(list
     115                                                   ',(car spec) ,@(cdr spec))
     116                                                 (list
     117                                                  'quote spec)))
     118                                           slots))))
     119           (slot-set! ,buf 'name ',name)
     120           ,buf))))))
    96121
    97122;;; convenience syntax
    98123
    99 (define-macro (-> obj slot)
    100   `(slot-ref ,obj ',slot))
    101 
    102 (define-macro (=> obj slot value)
    103   `(slot-set! ,obj ',slot ,value))
    104 
    105 (define-macro (~> obj slot proc)
    106   (let ((buf (gensym 'buf)))
    107     `(let ((,buf ,obj))
    108        (slot-set! ,buf ',slot (,proc (slot-ref ,buf ',slot))))))
     124(cond-expand
     125 (hygienic-macros
     126  (define-syntax ->
     127    (syntax-rules ()
     128      ((-> obj slot)
     129       (slot-ref obj 'slot)))))
     130 (else
     131  (define-macro (-> obj slot)
     132    `(slot-ref ,obj ',slot))))
     133
     134(cond-expand
     135 (hygienic-macros
     136  (define-syntax =>
     137    (syntax-rules ()
     138      ((=> obj slot value)
     139       (slot-set! obj 'slot value)))))
     140 (else
     141  (define-macro (=> obj slot value)
     142    `(slot-set! ,obj ',slot ,value))))
     143
     144(cond-expand
     145 (hygienic-macros
     146  (define-syntax ~>
     147    (syntax-rules ()
     148      ((~> obj slot proc)
     149       (slot-update! obj 'slot proc)))))
     150 (else
     151  (define-macro (~> obj slot proc)
     152    `(slot-update! ,obj ',slot ,proc))))
     153
     154(cond-expand
     155 (hygienic-macros
     156  (define-syntax ++>
     157    (syntax-rules ()
     158      ((++> obj slot)
     159       (let ((buf #f))
     160         (slot-update!
     161          obj 'slot
     162          (lambda (v)
     163            (set! buf (+ v 1))
     164            buf))
     165         buf))))
     166  (define-syntax >++
     167    (syntax-rules ()
     168      ((>++ obj slot)
     169       (let ((buf #f))
     170         (slot-update!
     171          obj 'slot
     172          (lambda (v)
     173            (set! buf v)
     174            (+ v 1)))
     175         buf)))))
     176 (else
     177  (define-macro (++> obj slot)
     178    `(let ((buf #f))
     179       (slot-update!
     180        ,obj ',slot
     181        (lambda (v)
     182          (set! buf (+ v 1))
     183          buf))
     184       buf))
     185  (define-macro (>++ obj slot)
     186    `(let ((buf #f))
     187       (slot-update!
     188        ,obj ',slot
     189        (lambda (v)
     190          (set! buf v)
     191          (+ v 1)))
     192       buf))))
     193
     194(cond-expand
     195 (hygienic-macros
     196  (define-syntax -->
     197    (syntax-rules ()
     198      ((--> obj slot)
     199       (let ((buf #f))
     200         (slot-update!
     201          obj 'slot
     202          (lambda (v)
     203            (set! buf (- v 1))
     204            buf))
     205         buf))))
     206  (define-syntax >--
     207    (syntax-rules ()
     208      ((>-- obj slot)
     209       (let ((buf #f))
     210         (slot-update!
     211          obj 'slot
     212          (lambda (v)
     213            (set! buf v)
     214            (- v 1)))
     215         buf)))))
     216 (else
     217  (define-macro (--> obj slot)
     218    `(let ((buf #f))
     219       (slot-update!
     220        ,obj ',slot
     221        (lambda (v)
     222          (set! buf (- v 1))
     223          buf))
     224       buf))
     225  (define-macro (>-- obj slot)
     226    `(let ((buf #f))
     227       (slot-update!
     228        ,obj ',slot
     229        (lambda (v)
     230          (set! buf v)
     231          (- v 1)))
     232       buf))))
  • modds/modds.setup

    r2533 r2542  
    1515 'modds
    1616 `("modds.scm" ,so-file "modds.html")
    17  '((version "1.1.0")
     17 '((syntax)
     18   (version "1.1.2")
    1819   (exports "modds-base.exports")
    1920   (require-at-runtime modds-base)
Note: See TracChangeset for help on using the changeset viewer.