home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / util / instance-manager.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  6.2 KB  |  151 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; This file has some random utilities dealing with instances.
  3.  
  4. ;;; Right now, this is a linear search off the class.
  5.  
  6. (define (lookup-instance alg-def class-def)
  7.  (setf alg-def (forward-def alg-def))
  8.  (setf class-def (forward-def class-def))
  9.  (if (algdata-skolem-type? alg-def)
  10.      (lookup-skolem-instance alg-def (algdata-classes alg-def) class-def)
  11.      (let ((res (lookup-instance-1 alg-def (class-instances class-def))))
  12.        (if (and (eq? res '#f) (algdata-real-tuple? alg-def))
  13.        (lookup-possible-tuple-instances alg-def class-def)
  14.        res))))
  15.  
  16. (define (lookup-instance-1 alg-def instances)
  17.   (cond ((null? instances)
  18.      '#f)
  19.     ((eq? (forward-def (instance-algdata (car instances))) alg-def)
  20.      (if (instance-ok? (car instances))
  21.          (car instances)
  22.          '#f))
  23.     (else
  24.      (lookup-instance-1 alg-def (cdr instances)))))
  25.  
  26. (define (lookup-skolem-instance alg classes class)
  27.   (cond ((null? classes)
  28.      '#f)
  29.     ((or (eq? (car classes) class)
  30.          (memq class (class-super* (car classes))))
  31.      (let ((inst (make instance 
  32.                 (algdata alg)
  33.                 (class class)
  34.                 (tyvars '())
  35.                 (context '())
  36.                 (gcontext '())
  37.                 (dictionary *undefined-def*)
  38.                 (skolem-inst? '#t))))
  39.        inst))
  40.     (else
  41.      (lookup-skolem-instance alg (cdr classes) class))))
  42.  
  43. (define (lookup-possible-tuple-instances alg-def class-def)
  44.   (cond ((eq? class-def (core-symbol "Eq"))
  45.      (get-tuple-eq-instance alg-def))
  46.     ((eq? class-def (core-symbol "Ord"))
  47.      (get-tuple-ord-instance alg-def))
  48.     ((eq? class-def (core-symbol "Ix"))
  49.      (get-tuple-ix-instance alg-def))
  50.     ((eq? class-def (core-symbol "Text"))
  51.      (get-tuple-text-instance alg-def))
  52.     ((eq? class-def (core-symbol "Binary"))
  53.      (get-tuple-binary-instance alg-def))
  54.     (else '#f)))
  55.  
  56. (define *saved-eq-instances* '())
  57. (define *saved-ord-instances* '())
  58. (define *saved-ix-instances* '())
  59. (define *saved-text-instances* '())
  60. (define *saved-binary-instances* '())
  61.  
  62. (define (get-tuple-eq-instance tpl)
  63.   (let ((res (assq tpl *saved-eq-instances*)))
  64.     (if (not (eq? res '#f))
  65.     (tuple-2-2 res)
  66.     (let ((inst (make-tuple-instance
  67.              tpl (core-symbol "Eq") (core-symbol "tupleEqDict"))))
  68.       (push (tuple tpl inst) *saved-eq-instances*)
  69.       inst))))
  70.  
  71. (define (get-tuple-ord-instance tpl)
  72.   (let ((res (assq tpl *saved-ord-instances*)))
  73.     (if (not (eq? res '#f))
  74.     (tuple-2-2 res)
  75.     (let ((inst (make-tuple-instance
  76.              tpl (core-symbol "Ord") (core-symbol "tupleOrdDict"))))
  77.       (push (tuple tpl inst) *saved-ord-instances*)
  78.       inst))))
  79.  
  80. (define (get-tuple-ix-instance tpl)
  81.   (let ((res (assq tpl *saved-ix-instances*)))
  82.     (if (not (eq? res '#f))
  83.     (tuple-2-2 res)
  84.     (let ((inst (make-tuple-instance
  85.              tpl (core-symbol "Ix") (core-symbol "tupleIxDict"))))
  86.       (push (tuple tpl inst) *saved-ix-instances*)
  87.       inst))))
  88.  
  89. (define (get-tuple-text-instance tpl)
  90.   (let ((res (assq tpl *saved-text-instances*)))
  91.     (if (not (eq? res '#f))
  92.     (tuple-2-2 res)
  93.     (let ((inst (make-tuple-instance
  94.              tpl (core-symbol "Text") (core-symbol "tupleTextDict"))))
  95.       (push (tuple tpl inst) *saved-text-instances*)
  96.       inst))))
  97.  
  98. (define (get-tuple-binary-instance tpl)
  99.   (let ((res (assq tpl *saved-binary-instances*)))
  100.     (if (not (eq? res '#f))
  101.     (tuple-2-2 res)
  102.     (let ((inst (make-tuple-instance
  103.              tpl (core-symbol "Binary")
  104.              (core-symbol "tupleBinaryDict"))))
  105.       (push (tuple tpl inst) *saved-binary-instances*)
  106.       inst))))
  107.  
  108. (define (make-tuple-instance algdata class dict)
  109.   (let* ((size (tuple-size algdata))
  110.      (tyvars (gen-symbols size))
  111.      (context (map (lambda (tyvar)
  112.               (**context (**class/def class) tyvar))
  113.             tyvars))
  114.      (sig (**tycon/def algdata (map (lambda (x) (**tyvar x)) tyvars)))
  115.      (gcontext (gtype-context (ast->gtype context sig))))
  116.     (make instance 
  117.       (algdata algdata)
  118.       (tyvars tyvars)
  119.       (class class)
  120.       (context context)
  121.       (gcontext gcontext)
  122.       (methods '())
  123.       (dictionary dict)
  124.       (ok? '#t)
  125.       (special? '#t))))
  126.  
  127. ;;; I know these are somewhere else too ...
  128.  
  129. (define (tuple-size alg)
  130.   (con-arity (car (algdata-constrs alg))))
  131.  
  132. (define (gen-symbols n)
  133.   (gen-symbols-1 n '(|a| |b| |c| |d| |e| |f| |g| |h| |i| |j| |k| |l| |m|
  134.              |n| |o| |p| |q| |r| |s| |t| |u| |v| |w| |x| |y| |z|)))
  135.  
  136. (define (gen-symbols-1 n vars)
  137.   (if (eqv? n 0)
  138.       '()
  139.       (if (null? vars)
  140.       (cons (string->symbol (format '#f "x~A" n))
  141.         (gen-symbols-1 (1- n) '()))
  142.       (cons (car vars) (gen-symbols-1 (1- n) (cdr vars))))))
  143.  
  144. ;;; This creates a new instance object and installs it.
  145.  
  146. (predefine (make-new-var name))  ; in tdecl/tdecl-utils.scm
  147.  
  148. (define (new-instance class algdata tyvars)
  149.  (let* ((dict-name
  150.      (string-append "dict-"
  151.             (symbol->string (print