home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / top / tuple.scm < prev   
Encoding:
Text File  |  1994-09-27  |  2.4 KB  |  96 lines  |  [TEXT/CCL2]
  1. ;;; This file creates type definitions for tuples of arbitrary size.
  2.  
  3. (define *tuple-definitions* '())
  4.  
  5. (define (init-tuples)
  6.   (setf *tuple-definitions* '()))
  7.  
  8. (define (tuple-tycon k)
  9.   (let ((tycon (assq k *tuple-definitions*)))
  10.     (if (eq? tycon '#f)
  11.     (new-tuple-tycon k)
  12.     (tuple-2-2 tycon))))
  13.  
  14. (define (tuple-constructor k)
  15.   (car (algdata-constrs (tuple-tycon k))))
  16.  
  17. (define (is-tuple-constructor? x)
  18.   (and (con? x) (is-tuple-tycon? (con-alg x))))
  19.  
  20. (define (is-tuple-tycon? x)
  21.   (and (algdata? x) (algdata-real-tuple? x)))
  22.  
  23. (define (tuple-constructor-arity x)
  24.   (con-arity x))
  25.  
  26. (predefine (ast->gtype c t))          ; in util/type-utils.scm
  27. (predefine (**arrow-type/l args))     ; in util/constructors.scm
  28. (predefine (**tyvar x))               ; in util/constructors.scm
  29.  
  30. (define (new-tuple-tycon k)
  31.   (cond ((eqv? k 0)
  32.      (core-symbol "UnitType"))
  33.     (else
  34.      (let* ((name (make-tuple-type-name k))
  35.         (cname (add-con-prefix name))
  36.         (dummy-vars (gen-dummy-names k))
  37.         (algdata (make algdata
  38.                    (name (string->symbol name))
  39.                    (module '*core*)
  40.                    (unit '*core*)
  41.                    (exported? '#t)
  42.                    (arity k)
  43.                    (n-constr 1)
  44.                    (context '())
  45.                    (tyvars dummy-vars)
  46.                    (classes '())  ;; filled in later
  47.                    (enum? '#f)
  48.                    (tuple? '#t)
  49.                    (real-tuple? '#t)
  50.                    (deriving '())))
  51.         (constr (make con
  52.                   (name (string->symbol cname))
  53.                   (module '*core*)
  54.                   (unit '*core*)
  55.                   (exported? '#t)
  56.                   (arity k)
  57.                   (types (map (function **tyvar) dummy-vars))
  58.                   (tag 0)
  59.                   (alg algdata)
  60.                   (slot-strict? '())
  61.                   (infix? '#f)))
  62.         (tyvars (map (function **tyvar) dummy-vars))
  63.         (tuple-type (**tycon/def algdata tyvars)))
  64.        (dotimes (i k)
  65.           (push '#f (con-slot-strict? constr)))
  66.        (setf (algdata-signature algdata)
  67.          (ast->gtype '() tuple-type))
  68.        (setf (con-signature constr)
  69.          (ast->gtype '() (**arrow-type/l
  70.                   (append tyvars (list tuple-type)))))
  71.        (setf (algdata-constrs algdata)
  72.          (list constr))
  73.        (push (tuple k algdata) *tuple-definitions*)
  74.        algdata))))
  75.  
  76. (define (make-tuple-type-name k)
  77.   (call-with-output-string
  78.    (lambda (p)
  79.      (write-string "(" p)
  80.      (dotimes (i (1- k))
  81.        (write-string "," p))
  82.      (write-string ")" p))))
  83.  
  84. (define (gen-dummy-names n)
  85.   (gen-dummy-names-1 n '()))
  86.  
  87. (define (gen-dummy-names-1 n l)
  88.   (if (eqv? n 0)
  89.       l
  90.       (gen-dummy-names-1 (1- n)
  91.              (cons (string->symbol (format '#f "a~A" n)) l))))
  92.  
  93.  
  94.  
  95.  
  96.