home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / sos / instance.scm < prev    next >
Text File  |  2000-02-21  |  9KB  |  269 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: instance.scm,v 1.9 2000/02/21 22:10:33 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1995-2000 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; 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 GNU
  15. ;;; 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., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;;; Instances
  22.  
  23. (declare (usual-integrations))
  24.  
  25. ;;;; Instance Constructor
  26.  
  27. ;;; First define macros to be used below, because the syntaxer
  28. ;;; requires them to appear before their first reference.
  29.  
  30. (define-macro (constructor-case n low high generator . generator-args)
  31.   ;; Assumes that (< LOW HIGH).
  32.   (let loop ((low low) (high high))
  33.     (let ((mid (quotient (+ high low) 2)))
  34.       (if (= mid low)
  35.       `(,generator ,@generator-args ,low)
  36.       `(IF (< ,n ,mid)
  37.            ,(loop low mid)
  38.            ,(loop mid high))))))
  39.  
  40. (define-macro (instance-constructor-1 n-slots)
  41.   `(IF N-INIT-ARGS
  42.        (IF (< N-INIT-ARGS 4)
  43.        (CONSTRUCTOR-CASE N-INIT-ARGS 0 4 INSTANCE-CONSTRUCTOR-2 ,n-slots)
  44.        (INSTANCE-CONSTRUCTOR-2 ,n-slots #F))
  45.        (INSTANCE-CONSTRUCTOR-2 ,n-slots NO-INITIALIZE-INSTANCE)))
  46.  
  47. (define-macro (instance-constructor-2 n-slots n-init-args)
  48.   (let ((make-names
  49.      (lambda (n prefix)
  50.        (make-initialized-list n
  51.          (lambda (index)
  52.            (intern (string-append prefix (number->string index))))))))
  53.     (call-with-values
  54.     (lambda ()
  55.       (cond ((eq? 'NO-INITIALIZE-INSTANCE n-init-args)
  56.          (values '() '()))
  57.         (n-init-args
  58.          (let ((ivs (make-names n-init-args "iv")))
  59.            (values ivs `((INITIALIZE-INSTANCE INSTANCE ,@ivs)))))
  60.         (else
  61.          (values 'IVS `((APPLY INITIALIZE-INSTANCE INSTANCE IVS))))))
  62.       (lambda (ivs ixs)
  63.     (let ((generator
  64.            (lambda (initialization)
  65.          (let ((sis (make-names n-slots "si"))
  66.                (svs (make-names n-slots "sv")))
  67.            (let ((l
  68.               `(LAMBDA (,@svs . ,ivs)
  69.                  (LET ((INSTANCE
  70.                     (OBJECT-NEW-TYPE
  71.                      (UCODE-TYPE RECORD)
  72.                      (MAKE-VECTOR INSTANCE-LENGTH
  73.                           RECORD-SLOT-UNINITIALIZED))))
  74.                    (%RECORD-SET! INSTANCE 0 INSTANCE-TAG)
  75.                    ,@(map (lambda (index value)
  76.                     `(%RECORD-SET! INSTANCE ,index ,value))
  77.                       sis
  78.                       svs)
  79.                    ,@initialization
  80.                    ,@ixs
  81.                    INSTANCE))))
  82.              (if (null? sis)
  83.              l
  84.              `(LET (,@(make-initialized-list n-slots
  85.                     (lambda (i)
  86.                       `(,(list-ref sis i)
  87.                     (LIST-REF INDEXES ,i)))))
  88.                 ,l)))))))
  89.       `(IF INITIALIZATION
  90.            ,(generator '((INITIALIZATION INSTANCE)))
  91.            ,(generator '())))))))
  92.  
  93. (define-macro (instance-constructor-3 test arity initialization ixs)
  94.   `(LETREC
  95.        ((PROCEDURE
  96.      (LAMBDA ARGS
  97.        (IF (NOT (,@test (LENGTH ARGS)))
  98.            (ERROR:WRONG-NUMBER-OF-ARGUMENTS PROCEDURE ,arity ARGS))
  99.        (LET ((INSTANCE
  100.           (OBJECT-NEW-TYPE
  101.            (UCODE-TYPE RECORD)
  102.            (MAKE-VECTOR INSTANCE-LENGTH
  103.                 RECORD-SLOT-UNINITIALIZED))))
  104.          (%RECORD-SET! INSTANCE 0 INSTANCE-TAG)
  105.          (DO ((INDEXES INDEXES (CDR INDEXES))
  106.           (ARGS ARGS (CDR ARGS)))
  107.          ((NULL? INDEXES)
  108.           ,@initialization
  109.           ,@ixs)
  110.            (%RECORD-SET! INSTANCE (CAR INDEXES) (CAR ARGS)))
  111.          INSTANCE))))
  112.      PROCEDURE))
  113.  
  114. (define (instance-constructor class slot-names #!optional init-arg-names)
  115.   (if (not (subclass? class <instance>))
  116.       (error:bad-range-argument class 'INSTANCE-CONSTRUCTOR))
  117.   (let ((slots (map (lambda (name) (class-slot class name #t)) slot-names))
  118.     (n-init-args
  119.      (cond ((or (default-object? init-arg-names)
  120.             (eq? #t init-arg-names))
  121.         #t)
  122.            ((or (eq? 'NO-INIT init-arg-names)
  123.             (eq? 'NO-INITIALIZE-INSTANCE init-arg-names))
  124.         #f)
  125.            ((and (list? init-arg-names)
  126.              (for-all? init-arg-names symbol?))
  127.         (length init-arg-names))
  128.            ((exact-nonnegative-integer? init-arg-names)
  129.         init-arg-names)
  130.            (else
  131.         (error:bad-range-argument init-arg-names
  132.                       'INSTANCE-CONSTRUCTOR))))
  133.     (instance-length (+ (length (class-slots class)) 1))
  134.     (instance-tag (class->dispatch-tag class)))
  135.     (let ((n-slots (length slots))
  136.       (indexes (map slot-index slots))
  137.       (initialization (make-initialization class slots)))
  138.       (cond ((eq? #t n-init-args)
  139.          (if initialization
  140.          (instance-constructor-3
  141.           (fix:<= n-slots) (cons n-slots #f)
  142.           ((initialization instance))
  143.           ((apply initialize-instance instance args)))
  144.          (instance-constructor-3
  145.           (fix:<= n-slots) (cons n-slots #f)
  146.           ()
  147.           ((apply initialize-instance instance args)))))
  148.         ((< n-slots 8)
  149.          (constructor-case n-slots 0 8 instance-constructor-1))
  150.         (n-init-args
  151.          (let ((n-args (+ n-slots n-init-args)))
  152.            (if initialization
  153.            (instance-constructor-3
  154.             (fix:= n-args) n-args
  155.             ((initialization instance))
  156.             ((apply initialize-instance instance args)))
  157.            (instance-constructor-3
  158.             (fix:= n-args) n-args
  159.             ()
  160.             ((apply initialize-instance instance args))))))
  161.         (initialization
  162.          (instance-constructor-3 (fix:= n-slots) n-slots
  163.                      ((initialization instance))
  164.                      ()))
  165.         (else
  166.          (instance-constructor-3 (fix:= n-slots) n-slots () ()))))))
  167.  
  168. (define-macro (make-initialization-1 if-n)
  169.   `(IF (< IV-N 8)
  170.        (CONSTRUCTOR-CASE IV-N 0 8 MAKE-INITIALIZATION-2 ,if-n)
  171.        (MAKE-INITIALIZATION-2 ,if-n #F)))
  172.  
  173. (define-macro (make-initialization-2 if-n iv-n)
  174.   (if (and if-n iv-n)
  175.       (let ((generate
  176.          (let ((make-names
  177.             (lambda (n prefix)
  178.               (make-initialized-list n
  179.             (lambda (index)
  180.               (intern (string-append prefix
  181.                          (number->string index))))))))
  182.            (lambda (n prefix isn vsn fv)
  183.          (let ((is (make-names n (string-append prefix "i")))
  184.                (vs (make-names n (string-append prefix "v"))))
  185.            (values
  186.             (append (make-initialized-list n
  187.                   (lambda (i)
  188.                 `(,(list-ref is i) (LIST-REF ,isn ,i))))
  189.                 (make-initialized-list n
  190.                   (lambda (i)
  191.                 `(,(list-ref vs i) (LIST-REF ,vsn ,i)))))
  192.             (make-initialized-list n
  193.               (lambda (i)
  194.             `(%RECORD-SET! INSTANCE
  195.                        ,(list-ref is i)
  196.                        ,(fv (list-ref vs i)))))))))))
  197.  
  198.       (call-with-values
  199.       (lambda ()
  200.         (generate if-n "f" 'IF-INDEXES 'INITIALIZERS
  201.               (lambda (expr) `(,expr))))
  202.     (lambda (if-bindings if-body)
  203.       (call-with-values
  204.           (lambda ()
  205.         (generate iv-n "v" 'IV-INDEXES 'INITIAL-VALUES
  206.               (lambda (expr) expr)))
  207.         (lambda (iv-bindings iv-body)
  208.           (if (and (null? if-bindings) (null? iv-bindings))
  209.           '#F
  210.           `(LET (,@if-bindings ,@iv-bindings)
  211.              (LAMBDA (INSTANCE)
  212.                ,@if-body
  213.                ,@iv-body))))))))
  214.       `(LAMBDA (INSTANCE)
  215.      (DO ((IS IF-INDEXES (CDR IS))
  216.           (VS INITIALIZERS (CDR VS)))
  217.          ((NULL? IS) UNSPECIFIC)
  218.        (%RECORD-SET! INSTANCE (CAR IS) ((CAR VS))))
  219.      (DO ((IS IV-INDEXES (CDR IS))
  220.           (VS INITIAL-VALUES (CDR VS)))
  221.          ((NULL? IS) UNSPECIFIC)
  222.        (%RECORD-SET! INSTANCE (CAR IS) (CAR VS))))))
  223.  
  224. (define (make-initialization class arg-slots)
  225.   (let ((if-slots
  226.      (list-transform-positive (class-slots class)
  227.        (lambda (slot)
  228.          (and (slot-initializer slot)
  229.           (not (memq slot arg-slots))))))
  230.     (iv-slots
  231.      (list-transform-positive (class-slots class)
  232.        (lambda (slot)
  233.          (and (slot-initial-value? slot)
  234.           (not (memq slot arg-slots)))))))
  235.     (let ((if-n (length if-slots))
  236.       (iv-n (length iv-slots))
  237.       (if-indexes (map slot-index if-slots))
  238.       (initializers (map slot-initializer if-slots))
  239.       (iv-indexes (map slot-index iv-slots))
  240.       (initial-values (map slot-initial-value iv-slots)))
  241.       (if (< if-n 4)
  242.       (constructor-case if-n 0 4 make-initialization-1)
  243.       (make-initialization-1 #f)))))
  244.  
  245. (define initialize-instance
  246.   (make-generic-procedure '(1 . #F) 'INITIALIZE-INSTANCE))
  247.  
  248. (define (instance? object)
  249.   (and (tagged-vector? object)
  250.        (class? (dispatch-tag-contents (tagged-vector-tag object)))))
  251.  
  252. (define (instance-class instance)
  253.   (dispatch-tag-contents (tagged-vector-tag instance)))
  254.  
  255. (define (instance-predicate specializer)
  256.   (if (not (specializer? specializer))
  257.       (error:wrong-type-argument specializer "specializer"
  258.                  'INSTANCE-PREDICATE))
  259.   (let ((predicate (make-generic-procedure 1)))
  260.     (let ((add
  261.        (lambda (c v)
  262.          (add-method predicate
  263.              (make-method (list c) (lambda (object) object v))))))
  264.       (add <object> #f)
  265.       (add specializer #t))
  266.     predicate))
  267.  
  268. (define (instance-of? object specializer)
  269.   (subclass? (object-class object) specializer))