home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / top / core-symbols.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  4.6 KB  |  155 lines  |  [TEXT/CCL2]
  1. ;;; This defines all core symbols.
  2.  
  3. ;;; Core symbols are stored in global variables.  The core-symbol
  4. ;;; macro just turns a string into a variable name.
  5.  
  6. (define-syntax (core-symbol str)
  7.   (make-core-symbol-name str))
  8.  
  9. (define-syntax (core-symbol/di str)
  10.   (make-core-symbol-name/di str))
  11.  
  12. (define (make-core-symbol-name str)
  13.   (string->symbol (string-append "*core-" str "*")))
  14.  
  15. (define (make-core-symbol-name/di str)
  16.   (make-core-symbol-name (add-di-prefix/string str)))
  17.  
  18. (define (symbol->core-var name)
  19.   (make-core-symbol-name (symbol->string name)))
  20.  
  21. (define (symbol->core-var/di name)
  22.   (make-core-symbol-name/di (symbol->string name)))
  23.  
  24. (define (get-core-var-names vars type)
  25.   (let ((res (assq type vars)))
  26.     (if (eq? res '#f)
  27.     '()
  28.     (map (function string->symbol) (tuple-2-2 res)))))
  29.  
  30. ;;; This is just used to create a define for each var without a
  31. ;;; value.
  32.  
  33. (define-syntax (define-core-variables)
  34.   `(begin
  35.      ,@(define-core-variables-1 *haskell-prelude-vars*)
  36.      ,@(define-core-variables-1 *haskell-noncore-vars*)))
  37.  
  38. (define (define-core-variables-1 vars)
  39.   (concat
  40.    (cons
  41.     (map (function init-core-symbol/di)
  42.         (get-core-var-names vars 'derivings))
  43.     (map (lambda (ty)
  44.        (map (function init-core-symbol)
  45.         (get-core-var-names vars ty)))
  46.      '(classes methods types constructors synonyms values)))))
  47.  
  48. (define (init-core-symbol sym)
  49.   `(define ,(symbol->core-var sym) '()))
  50.  
  51. (define (init-core-symbol/di sym)
  52.   `(define ,(symbol->core-var/di sym) '()))
  53.  
  54. (define-syntax (create-core-globals)
  55.   `(begin
  56.      (begin ,@(create-core-defs *haskell-prelude-vars* '#t))
  57.      (begin ,@(create-core-defs *haskell-noncore-vars* '#f))))
  58.  
  59. (define (create-core-defs defs prelude-core?)
  60.   `(,@(map (lambda (x) (define-core-value x prelude-core?))
  61.        (get-core-var-names defs 'values))
  62.      ,@(map (lambda (x) (define-core-method x prelude-core?))
  63.        (get-core-var-names defs 'methods))
  64.      ,@(map (lambda (x) (define-core-synonym x prelude-core?))
  65.        (get-core-var-names defs 'synonyms))
  66.      ,@(map (lambda (x) (define-core-class x prelude-core?))
  67.        (get-core-var-names defs 'classes))
  68.      ,@(map (lambda (x) (define-core-type x prelude-core?))
  69.         (get-core-var-names defs 'types))
  70.      ,@(map (lambda (x) (define-core-constr x prelude-core?))
  71.         (get-core-var-names defs 'constructors))
  72.      ,@(map (lambda (x) (define-core-deriving x prelude-core?))
  73.         (get-core-var-names defs 'derivings))))
  74.  
  75. (define (define-core-value name pc?)
  76.     `(setf ,(symbol->core-var name)
  77.        (make-core-value-definition ',name ',pc?)))
  78.  
  79. (define (make-core-value-definition name pc?)
  80.   (install-core-sym
  81.     (make var (name name) (module '|*Core|) (unit '|*Core|))
  82.     name
  83.     pc?))
  84.  
  85. (define (define-core-method name pc?)
  86.     `(setf ,(symbol->core-var name)
  87.        (make-core-method-definition ',name ',pc?)))
  88.  
  89. (define (make-core-method-definition name pc?)
  90.   (install-core-sym
  91.     (make method-var (name name) (module '|*Core|) (unit '|*Core|))
  92.     name
  93.     pc?))
  94.  
  95. (define (define-core-class name pc?)
  96.     `(setf ,(symbol->core-var name)
  97.        (make-core-class-definition ',name ',pc?)))
  98.  
  99. (define (make-core-class-definition name pc?)
  100.   (install-core-sym
  101.     (make class (name name) (module '|*Core|) (unit '|*Core|))
  102.     name
  103.     pc?))
  104.  
  105. (define (define-core-synonym name pc?)
  106.     `(setf ,(symbol->core-var name)
  107.        (make-core-synonym-definition ',name ',pc?)))
  108.  
  109. (define (make-core-synonym-definition name pc?)
  110.   (install-core-sym
  111.     (make synonym (name name) (module '|*Core|) (unit '|*Core|))
  112.     name
  113.     pc?))
  114.  
  115. (define (define-core-type name pc?)
  116.     `(setf ,(symbol->core-var name)
  117.        (make-core-type-definition ',name ',pc?)))
  118.  
  119. (define (make-core-type-definition name pc?)
  120.   (install-core-sym
  121.     (make algdata (name name) (module '|*Core|) (unit '|*Core|))
  122.     name
  123.     pc?))
  124.  
  125. (define (define-core-constr name pc?)
  126.     `(setf ,(symbol->core-var name)
  127.        (make-core-constr-definition ',name ',pc?)))
  128.  
  129. (define (make-core-constr-definition name pc?)
  130.   (setf name (add-con-prefix/symbol name))
  131.   (install-core-sym
  132.     (make con (name name) (module '|*Core|) (unit '|*Core|))
  133.     name
  134.     pc?))
  135.  
  136. (define (define-core-deriving name pc?)
  137.     `(setf ,(symbol->core-var/di name)
  138.        (make-core-deriving-definition ',name ',pc?)))
  139.  
  140. (define (make-core-deriving-definition name pc?)
  141.   (setf name (add-di-prefix name))
  142.   (install-core-sym
  143.    (make deriving (name name) (module '|*Core*|) (unit '|*Core*|))
  144.    name
  145.    pc?))
  146.  
  147. (define (install-core-sym def name preludecore?)
  148.   (setf (def-prelude? def) '#t)
  149.   (when preludecore? 
  150.     (setf (def-core? def) '#t))
  151.   (setf (table-entry (dynamic *core-symbols*) name) def)
  152.   (when preludecore?
  153.     (setf (table-entry (dynamic *prelude-core-symbols*) name) def))
  154.   def)
  155.