1: ;;;
    2: ;;; object.scm - object system
    3: ;;;  
    4: ;;;   Copyright (c) 2000-2007  Shiro Kawai  <shiro@acm.org>
    5: ;;;   
    6: ;;;   Redistribution and use in source and binary forms, with or without
    7: ;;;   modification, are permitted provided that the following conditions
    8: ;;;   are met:
    9: ;;;   
   10: ;;;   1. Redistributions of source code must retain the above copyright
   11: ;;;      notice, this list of conditions and the following disclaimer.
   12: ;;;  
   13: ;;;   2. Redistributions in binary form must reproduce the above copyright
   14: ;;;      notice, this list of conditions and the following disclaimer in the
   15: ;;;      documentation and/or other materials provided with the distribution.
   16: ;;;  
   17: ;;;   3. Neither the name of the authors nor the names of its contributors
   18: ;;;      may be used to endorse or promote products derived from this
   19: ;;;      software without specific prior written permission.
   20: ;;;  
   21: ;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22: ;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23: ;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   24: ;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   25: ;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   26: ;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
   27: ;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
   28: ;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
   29: ;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
   30: ;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   31: ;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   32: ;;;  
   33: ;;;  $Id: objlib.scm,v 1.8 2007/10/27 10:07:33 shirok Exp $
   34: ;;;
   35: 
   36: ;; This module is not meant to be `use'd.   It is just to hide
   37: ;; auxiliary procedures from the rest of the system.  The initialization
   38: ;; file loads this file, and this file inserts exported symbols into
   39: ;; gauche module explicitly.
   40: (define-module gauche.object)
   41: (select-module gauche.object)
   42: 
   43: ;;; I'm trying to make MOP as close to STklos and Goops as possible.
   44: ;;; The perfect compatibility can't be done since the underlying implemenation
   45: ;;; in C differs a bit.
   46: 
   47: ;; Bootstrapping "make"
   48: ;;   We already have generic-function for "make" defined in C.  Just wanted
   49: ;;   to make a method specialized for <class>, i.e. the most common "make".
   50: ;;   However, we can't say (make <method> ...) before we have a make method.
   51: ;;   So we have to "hard wire" the method creation.
   52: 
   53: (let ((%make (lambda (class . initargs)
   54:                (let ((obj (allocate-instance class initargs)))
   55:                  (initialize obj initargs)
   56:                  obj)))
   57:       (body  (lambda (class initargs next-method)
   58:                (let ((obj (allocate-instance class initargs)))
   59:                  (initialize obj initargs)
   60:                  obj))))
   61:   (add-method! make
   62:                (%make <method>
   63:                       :generic make
   64:                       :specializers (list <class>)
   65:                       :lambda-list '(class . initargs)
   66:                       :body body)))
   67: 
   68: ;;----------------------------------------------------------------
   69: ;; Generic function
   70: ;;
   71: 
   72: ;(define-macro (define-generic name . opts)
   73: ;  (%expand-define-generic name opts))
   74: 
   75: (define (%expand-define-generic name opts)
   76:   (receive (true-name getter-name) (%check-setter-name name)
   77:     (let ((class (get-keyword :class opts <generic>))
   78:           (other (delete-keyword :class opts)))
   79:       (if getter-name
   80:         `(begin
   81:            (define ,true-name (make ,class :name ',true-name ,@other))
   82:            (set! (setter ,getter-name) ,true-name))
   83:         `(define ,true-name (make ,class :name ',true-name ,@other))))))
   84: 
   85: ;; allow (setter name) type declaration
   86: (define (%check-setter-name name)
   87:   (cond ((symbol? name) (values name #f))
   88:         ((identifier? name) (values name #f))
   89:         ((and (pair? name) (eq? (car name) 'setter)
   90:               (pair? (cdr name)) (or (symbol? (cadr name))
   91:                                      (identifier? (cadr name)))
   92:               (null? (cddr name)))
   93:          (values (%make-setter-name (cadr name)) (cadr name)))
   94:         (else (error "Bad name for generic function or method" name))))
   95: 
   96: (define (%make-setter-name name)
   97:   (string->symbol (format #f "setter of ~a" name)))
   98: 
   99: ;;----------------------------------------------------------------
  100: ;; Method
  101: ;;
  102: 
  103: ;(define-macro (define-method name specs . body)
  104: ;  (%expand-define-macro name specs body))
  105: 
  106: (define (%expand-define-method name specs body)
  107:   (receive (specializers lambda-list body-args)
  108:       (let loop ((ss specs))
  109:         (cond ((null? ss)
  110:                (values '() '() (list 'next-method)))
  111:               ((not (pair? ss))
  112:                (values '() ss (list ss 'next-method)))
  113:               ((pair? (car ss))
  114:                (receive result (loop (cdr ss))
  115:                  (apply values (map cons
  116:                                     (list (car (cdar ss)) (caar ss) (caar ss))
  117:                                     result))))
  118:               (else
  119:                (receive result (loop (cdr ss))
  120:                  (apply values (map cons
  121:                                     (list '<top> (car ss) (car ss))
  122:                                     result))))
  123:               ))
  124:     (receive (true-name getter-name) (%check-setter-name name)
  125:       (let ((gf (gensym)))
  126:         `(let ((,gf (%ensure-generic-function ',true-name (current-module))))
  127:            (add-method! ,gf
  128:                         (make <method>
  129:                           :generic ,gf
  130:                           :specializers (list ,@specializers)
  131:                           :lambda-list ',lambda-list
  132:                           :body (lambda ,body-args ,@body)))
  133:            ,@(if getter-name
  134:                  `((unless (has-setter? ,getter-name)
  135:                      (set! (setter ,getter-name) ,gf)))
  136:                  '())
  137:            ,gf)))
  138:     ))
  139: 
  140: ;;----------------------------------------------------------------
  141: ;; Class
  142: ;;
  143: 
  144: ;(define-macro (define-class name supers slots . options)
  145: ;  (%expand-define-class name supers slots options))
  146: 
  147: (define make-identifier (with-module gauche.internal make-identifier))
  148: 
  149: (define (%expand-define-class name supers slots options)
  150:   (let* ((metaclass (or (get-keyword :metaclass options #f)
  151:                         `(,(make-identifier '%get-default-metaclass
  152:                                             (current-module) '())
  153:                           (list ,@supers))))
  154:          (slot-defs (map %process-slot-definition slots))
  155:          (class     (gensym))
  156:          (slot      (gensym)))
  157:     `(define ,name
  158:        (let ((,class (make ,metaclass
  159:                        :name ',name
  160:                        :supers (list ,@supers)
  161:                        :slots (list ,@slot-defs)
  162:                        :defined-modules (list (current-module))
  163:                        ,@options)))
  164:          (when (%check-class-binding ',name (current-module))
  165:            (redefine-class! ,name ,class))
  166:          (for-each (lambda (,slot)
  167:                      (,(make-identifier '%make-accessor (current-module) '())
  168:                       ,class ,slot (current-module)))
  169:                    (class-slots ,class))
  170:          ,class))
  171:     ))
  172: 
  173: (define (%process-slot-definition sdef)
  174:   (if (pair? sdef)
  175:     (let loop ((opts (cdr sdef)) (r '()))
  176:       (cond ((null? opts) `(list ',(car sdef) ,@(reverse! r)))
  177:             ((not (and (pair? opts) (pair? (cdr opts))))
  178:              (error "bad slot specification:" sdef))
  179:             (else
  180:              (case (car opts)
  181:                ((:initform :init-form)
  182:                 (loop (cddr opts)
  183:                       (list* `(lambda () ,(cadr opts)) :init-thunk r)))
  184:                ((:getter :setter :accessor)
  185:                 (loop (cddr opts)
  186:                       (list* `',(cadr opts) (car opts) r)))
  187:                (else
  188:                 (loop (cddr opts) (list* (cadr opts) (car opts) r))))
  189:              )))
  190:     `'(,sdef)))
  191: 
  192: ;; Determine default metaclass, that is a class inheriting all the metaclasses
  193: ;; of supers.  The idea is taken from stklos.  The difference is that
  194: ;; metaclass calculation is done at runtime in Gauche, while at compile-time
  195: ;; in STklos.
  196: (define %get-default-metaclass
  197:   (let ((generated-metas '()))
  198:     (define (find-metaclass metasupers)
  199:       (cond ((assoc metasupers generated-metas)
  200:              => (lambda (got) (cdr got)))
  201:             (else (make-metaclass metasupers))))
  202:     (define (make-metaclass metasupers)
  203:       (let ((meta (make <class>
  204:                     :supers metasupers :name (gensym "metaclass") :slots '())))
  205:         (set! generated-metas (acons metasupers meta generated-metas))
  206:         meta))
  207: 
  208:     (lambda (supers)
  209:       (if (null? supers)
  210:           <class>
  211:           (let* ((all-metas (map class-of supers))
  212:                  (all-cpls  (apply append
  213:                                    (map (lambda (m)
  214:                                           (cdr (class-precedence-list m)))
  215:                                         all-metas)))
  216:                  (needed '()))
  217:             (for-each
  218:              (lambda (m)
  219:                (when (and (not (memq m all-cpls))
  220:                           (not (memq m needed)))
  221:                  (set! needed (cons m needed))))
  222:              all-metas)
  223:             (if (null? (cdr needed))
  224:                 (car needed)
  225:                 (find-metaclass (reverse! needed))))))
  226:     ))
  227: 
  228: ;;; Method INITIALIZE (class <class>) initargs
  229: ;;;  NB: we always add <object> to the direct supers, for C defined
  230: ;;;  base classes may not be inheriting from it.
  231: (define-method initialize ((class <class>) initargs)
  232:   (next-method)
  233:   (let* ((slots  (get-keyword :slots  initargs '()))
  234:          (sup    (get-keyword :supers initargs '()))
  235:          (supers (append sup (list <object>)))
  236:          )
  237:     ;; The order of initialization is somewhat important, since calculation
  238:     ;; of values of some slots depends on the other slots.
  239:     (slot-set! class 'direct-supers supers)
  240:     (slot-set! class 'cpl (compute-cpl class))
  241:     (slot-set! class 'direct-slots
  242:                (map (lambda (s) (if (pair? s) s (list s))) slots))
  243:     ;; note: num-instance-slots is set up during compute-get-n-set.
  244:     (let* ((slots (compute-slots class)))
  245:       (slot-set! class 'slots slots)
  246:       (slot-set! class 'accessors
  247:                  (map (lambda (s)
  248:                         ;; returns (name . #<slot-accessor>)
  249:                         (cons (car s)
  250:                               (compute-slot-accessor
  251:                                class s
  252:                                (compute-get-n-set class s))))
  253:                       slots))
  254:       )
  255:     ;; bookkeeping for class redefinition
  256:     (slot-set! class 'initargs initargs)
  257:     (for-each (lambda (super) (%add-direct-subclass! super class))
  258:               supers)
  259:     ))
  260: 
  261: (define (%make-accessor class slot module)
  262:   (let* ((name      (slot-definition-name slot))
  263:          (sa        (class-slot-accessor class name))
  264:          (%getter   (slot-definition-getter slot))
  265:          (%setter   (slot-definition-setter slot))
  266:          (%accessor (slot-definition-accessor slot)))
  267: 
  268:     (define (make-getter gf)
  269:       (add-method! gf
  270:                    (make <accessor-method>
  271:                      :generic gf :specializers (list class)
  272:                      :slot-accessor sa :lambda-list '(obj)
  273:                      :body (lambda (obj next-method) #f) ;; dummy
  274:                      )))
  275: 
  276:     (define (make-setter gf)
  277:       (add-method! gf
  278:                    (make <accessor-method>
  279:                      :generic gf :specializers (list class <top>)
  280:                      :slot-accessor sa :lambda-list '(obj val)
  281:                      :body (lambda (obj val next-method) #f) ;; dummy
  282:                      )))
  283: 
  284:     (when %getter
  285:       (make-getter (%ensure-generic-function %getter module)))
  286:     (when %setter
  287:       (make-setter (%ensure-generic-function %setter module)))
  288:     (when %accessor
  289:       (let ((gf  (%ensure-generic-function %accessor module))
  290:             (gfs (%ensure-generic-function (%make-setter-name %accessor)
  291:                                            module)))
  292:         (make-getter gf)
  293:         (make-setter gfs)
  294:         (set! (setter gf) gfs)
  295:         ))
  296:     ))
  297:  
  298: ;;; Method COMPUTE-SLOTS (class <class>)
  299: (define-method compute-slots ((class <class>))
  300:   (let ((cpl (slot-ref class 'cpl))
  301:         (slots '()))
  302:     (for-each (lambda (c)
  303:                 (for-each (lambda (slot)
  304:                             (unless (assq (car slot) slots)
  305:                               (set! slots (cons slot slots))))
  306:                           (slot-ref c 'direct-slots)))
  307:               cpl)
  308:     (reverse slots)))
  309: 
  310: ;;; Method COMPUTE-GET-N-SET (class <class>) slot
  311: ;;;   May return:
  312: ;;;      integer for instance slot
  313: ;;;      list    (getter [setter [bound? [allocate?]]])
  314: ;;;      slot accessor
  315: (define-method compute-get-n-set ((class <class>) slot)
  316: 
  317:   ;; NB: STklos ignores :initform slot option for class slots, but
  318:   ;;     I think it's sometimes useful.
  319:   (define (make-class-slot)
  320:     (let* ((init-value (slot-definition-option slot :init-value (undefined)))
  321:            (init-thunk (slot-definition-option slot :init-thunk #f)))
  322:       (if init-thunk
  323:         (%make-class-slot (init-thunk))
  324:         (%make-class-slot init-value))))
  325:   
  326:   (let ((slot-name (slot-definition-name slot))
  327:         (alloc (slot-definition-allocation slot)))
  328:     (case alloc
  329:       ((:instance)
  330:        (let ((num (slot-ref class 'num-instance-slots)))
  331:          (slot-set! class 'num-instance-slots (+ num 1))
  332:          num))
  333:       ((:class)
  334:        (if (assq slot-name (class-direct-slots class))
  335:            (make-class-slot)
  336:            (let loop ((cpl (class-precedence-list class)))
  337:              (cond ((null? cpl)
  338:                     (error "something wrong with slot inheritance of" class))
  339:                    ((assq slot-name (class-direct-slots (car cpl)))
  340:                     (class-slot-accessor (car cpl) slot-name))
  341:                    (else (loop (cdr cpl)))))))
  342:       ((:each-subclass)
  343:        (make-class-slot))
  344:       ((:virtual)
  345:        (let ((getter (slot-definition-option slot :slot-ref #f))
  346:              (setter (slot-definition-option slot :slot-set! #f))
  347:              (bound? (slot-definition-option slot :slot-bound? #f)))
  348:          (unless (procedure? getter)
  349:            (error "virtual slot requires at least :slot-ref:" slot))
  350:          (list getter setter bound?)))
  351:       ((:builtin)
  352:        (or (slot-definition-option slot :slot-accessor #f)
  353:            (errorf "builtin slot ~s of class ~s doesn't have associated slot accessor"
  354:                    (car slot) class)))
  355:       (else
  356:        (error "unsupported slot allocation:" alloc)))))
  357: 
  358: (define (%make-class-slot cell)
  359:   (list (lambda (o)   cell)
  360:         (lambda (o v) (set! cell v))
  361:         (lambda (o)   (not (undefined? cell)))))
  362: 
  363: ;; METHOD COMPUTE-SLOT-ACCESSOR (class <class>) g-n-s
  364: ;;  this method doesn't have equivalent one in STklos.
  365: (define-method compute-slot-accessor ((class <class>) slot gns)
  366:   (if (is-a? gns <slot-accessor>)
  367:       gns
  368:       (apply make <slot-accessor>
  369:              :class class :name (slot-definition-name slot)
  370:              `(,@(cond
  371:                   ((integer? gns) (list :slot-number gns :initializable #t))
  372:                   ((list? gns)
  373:                    (list :getter (car gns)
  374:                          :setter (list-ref gns 1 #f)
  375:                          :bound? (list-ref gns 2 #f)
  376:                          :initializable (list-ref gns 3 #f)))
  377:                   (else
  378:                    (errorf "bad getter-and-setter returned by compute-get-n-set for ~s ~s: ~s"
  379:                            class slot gns)))
  380:                ,@(cdr slot)))))
  381: 
  382: ;; access class allocated slot.  API compatible with Goops.
  383: (define (%class-slot-gns class slot-name acc-type)
  384:   (cond ((class-slot-definition class slot-name)
  385:          => (lambda (slot)
  386:               (if (memv (slot-definition-allocation slot)
  387:                         '(:class :each-subclass))
  388:                 (slot-ref (class-slot-accessor class slot-name) acc-type)
  389:                 (errorf "attempt to access non-class allocated slot ~s of class ~s as a class slot." slot-name class))))
  390:         (else
  391:          (errorf "attempt to access non-existent slot ~s of class ~s as a class slot." slot-name class))))
  392: 
  393: (define (class-slot-set! class slot-name val)
  394:   (apply (%class-slot-gns class slot-name 'setter) (list #f val)))
  395: 
  396: (define class-slot-ref
  397:   (getter-with-setter
  398:    (lambda (class slot-name)
  399:      (let ((val (apply (%class-slot-gns class slot-name 'getter) '(#f))))
  400:        (if (undefined? val)
  401:            (slot-unbound class slot-name)
  402:            val)))
  403:    class-slot-set!))
  404: 
  405: (define (class-slot-bound? class slot-name)
  406:   (apply (%class-slot-gns class slot-name 'bound?) '(#f)))
  407: 
  408: ;; default class printer.  Avoid using class-name so that in case
  409: ;; when obj's class has been redefined, this wouldn't trigger updating obj.
  410: (define-method write-object ((obj <class>) out)
  411:   (format out "#<class ~a>"
  412:           (slot-ref-using-class (current-class-of obj) obj 'name)))
  413: 
  414: ;; convenient routine to push the value to the slot.
  415: ;; this can be optimized later.
  416: (define (slot-push! obj slot value)
  417:   (slot-set! obj slot (cons value (slot-ref obj slot))))
  418: 
  419: ;; default unbound slot and missing slot handlers.
  420: ;; we avoid printing object itself in the error message, for it might
  421: ;; cause an infinite loop (via write-object method).
  422: (define-method slot-unbound ((class <class>) obj slot)
  423:   (errorf "slot ~s of object of class ~a is unbound" slot class))
  424: 
  425: (define-method slot-missing ((class <class>) obj slot . value)
  426:   (errorf "object of class ~s doesn't have such slot: ~s" class slot))
  427: 
  428: (define (slot-exists? obj slot)
  429:   (slot-exists-using-class? (class-of obj) obj slot))
  430: 
  431: (define-method slot-exists-using-class? (class obj slot)
  432:   (not (not (assq slot (class-slots class)))))
  433: 
  434: ;;----------------------------------------------------------------
  435: ;; Class Redefinition
  436: ;;
  437: 
  438: ;; implemented in gauche/redefutil.scm 
  439: ;(autoload "gauche/redefutil"
  440: ;          redefine-class! class-redefinition
  441: ;          update-direct-subclass! change-object-class)
  442: ;(with-module gauche
  443: ;  (autoload "gauche/redefutil"
  444: ;            redefine-class! class-redefinition
  445: ;            update-direct-subclass! change-object-class))
  446: 
  447: ;; change-class gf is defined in C, so we can't use autoload for it.
  448: (define-method change-class ((obj <object>) (new-class <class>))
  449:   (change-object-class obj (current-class-of obj) new-class))
  450: 
  451: ;;----------------------------------------------------------------
  452: ;; Method Application
  453: ;;
  454: 
  455: ;; Like stklos or goops, pure generic is handled completely in C
  456: ;; and the following protocol is skipped.
  457: ;;
  458: ;; apply-generic [GF]
  459: ;;   compute-applicable-methods [GF, method defined in C]
  460: ;;   sort-applicable-methods [GF]
  461: ;;     method-more-specific? [GF, method defined in C]
  462: ;;   apply-methods [GF]
  463: ;;     apply-method [GF]
  464: ;;
  465: ;; The protocol mimics STklos, but the underlying application mechanism
  466: ;; differs a bit.
  467: 
  468: (define-method apply-generic ((gf <generic>) args)
  469:   (let ((methods (compute-applicable-methods gf args)))
  470:     (apply-methods gf (sort-applicable-methods gf methods args) args)))
  471: 
  472: (define-method sort-applicable-methods ((gf <generic>) methods args)
  473:   (let ((types (map class-of args)))
  474:     (sort methods (lambda (x y) (method-more-specific? x y types)))))
  475: 
  476: (define-method apply-methods ((gf <generic>) methods args)
  477:   (apply-method gf methods %make-next-method args))
  478: 
  479: (define-method apply-method ((gf <generic>) methods build-next args)
  480:   (apply (build-next gf methods args) args))
  481:       
  482: ;;----------------------------------------------------------------
  483: ;; Introspection routines
  484: ;;
  485: 
  486: (define (class-name class) (slot-ref class 'name))
  487: (define (class-precedence-list class) (slot-ref class 'cpl))
  488: (define (class-direct-supers class) (slot-ref class 'direct-supers))
  489: (define (class-direct-slots class) (slot-ref class 'direct-slots))
  490: (define (class-direct-methods class) (slot-ref class 'direct-methods))
  491: (define (class-direct-subclasses class) (slot-ref class 'direct-subclasses))
  492: (define (class-slots class) (slot-ref class 'slots))
  493: 
  494: (define (slot-definition-name slot) (car slot))
  495: (define (slot-definition-options slot) (cdr slot))
  496: (define (slot-definition-option slot key . default)
  497:   (apply get-keyword key (cdr slot) default))
  498: (define (slot-definition-allocation slot)
  499:   (get-keyword :allocation (cdr slot) :instance))
  500: (define (slot-definition-getter slot)
  501:   (get-keyword :getter (cdr slot) #f))
  502: (define (slot-definition-setter slot)
  503:   (get-keyword :setter (cdr slot) #f))
  504: (define (slot-definition-accessor slot)
  505:   (get-keyword :accessor (cdr slot) #f))
  506: 
  507: (define (class-slot-definition class slot-name)
  508:   (assq slot-name (slot-ref class 'slots)))
  509: (define (class-slot-accessor class slot-name)
  510:   (cond ((assq slot-name (slot-ref class 'accessors)) => cdr)
  511:         (else #f)))
  512: 
  513: ;;----------------------------------------------------------------
  514: ;; Generic coercion
  515: ;;  (should this be in separate file, e.g. coerce.scm?
  516: ;;   autoload may have problem with autoloading generic fn.)
  517: 
  518: (define-method x->string ((obj <string>)) obj)
  519: (define-method x->string ((obj <number>)) (number->string obj))
  520: (define-method x->string ((obj <symbol>)) (symbol->string obj))
  521: (define-method x->string ((obj <char>))   (string obj))
  522: (define-method x->string ((obj <top>))    (write-to-string obj display))