home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / SCOOPS / INSTANCE.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  4.7 KB  |  136 lines
  1. ;* INSTANCE.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Scoops: Compilation & Creattion of an Instance        *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Amitabh Srivastava        Date: 1986        *
  16. ;* Revision history:                            *
  17. ;* -  7 Mar 88: Lutz Euler                        *
  18. ;*    Fehler war:                            *
  19. ;*    MAKE-INSTANCE hat optionale Parameter, die Instanzvariablen    *
  20. ;*    anders als in der Klassendefinition vorbesetzen. Dies wurde    *
  21. ;*    bisher ueberhaupt nicht beruecksichtigt, d.h. die optionalen    *
  22. ;*    Parameter wurden ignoriert. Die Aenderung betrifft die Funktion    *
  23. ;*    %MAKE-INST-TEMPLATE. Die neue Version kann Variablen        *
  24. ;*    initialisieren,    sie ueberprueft dabei aber nicht, ob sie mit    *
  25. ;*    der Vereinbarung "inittable" in der Klassendefinition vereinbar    *
  26. ;*    sind. Die Argumente von MAKE-INSTANCE werden dabei syntaktisch    *
  27. ;*    nicht ueberprueft, sondern es wird nur eine LET-Form durch    *
  28. ;*    paarweise Kombination der Argumente erzeugt.            *
  29. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  30. ;*                                    *
  31. ;*                    ``In nomine omnipotentii dei''    *
  32. ;************************************************************************
  33.  
  34. ;
  35.  
  36. (macro compile-class
  37.   (lambda (e)
  38.     (let ((name (cadr e))
  39.           (class (%sc-name->class (cadr e))))
  40.       (if (%sc-class-compiled class)
  41.           name
  42.           (begin
  43.            (%inherit-method-vars class)
  44.            (%make-template name class))))))
  45.  
  46. ;
  47.  
  48. (define %sc-compile-class
  49.   (lambda (class)
  50.     (%inherit-method-vars class)
  51.     (eval (%make-template (%sc-name class) class))))
  52.  
  53. ;
  54.  
  55. (macro make-instance
  56.   (lambda (e)
  57.     (cons (list '%sc-inst-template (cadr e)) (cddr e))))
  58. ;
  59.  
  60. (define %uncompiled-make-instance
  61.   (lambda (class)
  62.     (lambda init-msg
  63.       (%sc-compile-class class)
  64.       (apply (%sc-inst-template class) init-msg))))
  65.  
  66.  
  67.  
  68. ;
  69.  
  70. (define %make-template
  71.   (lambda (name class)
  72.     `(begin
  73. ; do some work to make compile-file work
  74.        (%sc-set-allcvs ,name ',(%sc-allcvs class))
  75.        (%sc-set-allivs ,name ',(%sc-allivs class))
  76.        (%sc-set-method-structure ,name
  77.             ',(%sc-method-structure class))
  78. ; prepare make-instance template
  79.        (%sc-set-inst-template ,name
  80.           ,(%make-inst-template (%sc-allcvs class)
  81.                                (%sc-allivs class)
  82.                                (%sc-method-structure class)
  83.                                name class))
  84.        (%sc-set-class-compiled ,name #T)
  85.        (%sc-set-class-inherited ,name #T)
  86.        (%sign-on ',name ,name)
  87. ;
  88.        ',name)))
  89. ;
  90.  
  91.  
  92. (define %make-inst-template
  93.   (lambda (cvs ivs method-structure name class)
  94.     (let ((methods
  95.             (append
  96.                 (mapcar
  97.                   (lambda (a)
  98.                     `(,(car a) (%sc-get-meth-value ',(car a) ,(caadr a))))
  99.                   method-structure)
  100.                  '((%*methods*% '-))))
  101.           (classvar (append cvs '((%*classvars*% '-))))
  102.           (instvar  (append ivs '((%*instvars*% '-)))))
  103. ; dummy variables are added to methods, cvs, and ivs to prevent the
  104. ; compiler from folding them away.
  105.  
  106.       `(let ((%sc-class ,name))
  107.          (let ,methods
  108.            (%sc-set-method-env ,name (the-environment))
  109.             (let ,classvar
  110.               (%sc-set-class-env ,name (the-environment))
  111.  
  112. ; Wert von %make-inst-template ist eine Funktion mit beliebig vielen
  113. ; Parametern, die an %sc-init-vals als Liste gebunden werden.
  114. ; Diese Parameter sind die optionalen Parameter von make-instance,
  115. ; die Instanzvariablen vorbesetzen.
  116. ; Diese erzeugte Funktion muss dann eine Umgebung zurueckgeben, in
  117. ; der diese Instanzvariablen richtig gebunden sind.
  118. ; Die bisherige Version hat die optionalen Parameter nicht beruecksichtigt.
  119. ; Alte Version:
  120. ;             (lambda %sc-init-vals
  121. ;               (let ,instvar
  122. ;                 (the-environment)))
  123. ; Neue Version vom 07.03.88:
  124.               (lambda %sc-init-vals
  125.                 (let ,instvar
  126.                   (eval
  127.                     `(let
  128.                        ,(let loop ((rest %sc-init-vals))
  129.                           (if (null? rest)
  130.                               '()
  131.                               `((,(car rest) ',(cadr rest))
  132.                                 ,@(loop (cddr rest)))))
  133.                        (the-environment))
  134.                     (the-environment))))))))))
  135.  
  136.