home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / csys / structure-save.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  26.5 KB  |  773 lines  |  [TEXT/CCL2]
  1. fixity
  2.       (add-dump-init `(set-var-fixity ,dexp
  3.                       ',(fixity-associativity fixity)
  4.                       ,(fixity-precedence fixity))))
  5.     ;; Save values of simple variables to permit inlining.
  6.     ;; Save values of structured constants to permit folding of flic-sel
  7.     ;; operations -- this is necessary to optimize dictionary lookups.
  8.     ;; If value is not used, zap it to free up memory.
  9.     (if (or sel?
  10.         (and value
  11.          (is-type? 'flic-app value)
  12.          (structured-constant-app?
  13.           (flic-app-fn value) (flic-app-args value)))
  14.         ;; optimizer uses inline-value in preference to value anyway!
  15.         (and simple? (not inline-value)))
  16.     (add-dump-init `(set-var-value ,dexp ,(dump-flic-top value)))
  17.     (setf (var-value var) '#f))
  18.     (when inline-value
  19.       (add-dump-init
  20.         `(set-var-inline-value ,dexp ,(dump-flic-top inline-value))))
  21.     (when (not (null? specializers))
  22.       (add-dump-init
  23.         `(set-var-specializers
  24.         ,dexp
  25.         (list ,@(map (lambda (s)
  26.                `(cons ,(dump-object (car s))
  27.                   ,(dump-flic-top (cdr s))))
  28.              specializers)))))
  29.     ;; Save extra stuff for method vars
  30.     (when method-var?
  31.       (add-dump-init
  32.         `(init-method-var-slots
  33.        ,dexp
  34.        ,(dump-object (method-var-class var))
  35.        ,(dump-object (method-var-default var))
  36.        ,(dump-object (method-var-method-signature var)))))
  37.     ))
  38.  
  39.  
  40. (define-walker-method dump method-var (var)
  41.   (dump-method-var/n var))
  42.  
  43. (define (dump-method-var/n var)
  44.   (with-new-def (dexp var *number-vars-dumped*)
  45.     (do-dump-var dexp var '#t)))
  46.  
  47. (define-walker-method dump con (con)
  48.   (dump-con/n con))
  49.  
  50. (define (dump-con/n con)
  51.   (with-new-def (dexp con *number-types-dumped*)
  52.     (when (not (def-prelude? con))
  53.       (setf dexp (def-dump-index con)))
  54.     (mlet (((file line) (dump-source-pointer (def-where-defined con))))
  55.       (add-dump-init
  56.        `(init-con-slots
  57.      ,dexp
  58.      ,(con-arity con)
  59.      ,(dump-object (con-types con))
  60.      ,(dump-object (con-signature con))
  61.      ,(con-tag con)
  62.  
  63.      ,(dump-object (con-alg con))
  64.      ,(dump-object (con-fixity con))
  65.      ,(con-infix? con)
  66.      ',file
  67.      ',line)))
  68.     (when (memq '#t (con-slot-strict? con))
  69.       (add-dump-init
  70.         `(set-con-slot-strict? ,dexp
  71.                    ,(dump-strictness (con-slot-strict? con)))))
  72.     (when (not (null? (con-lisp-fns con)))
  73.       (add-dump-init
  74.         `(set-con-lisp-fns ,dexp ',(con-lisp-fns con))))))
  75.  
  76. (define-walker-method dump algdata (alg)
  77.   (dump-algdata/n alg))
  78.  
  79. (define (dump-algdata/n alg)
  80.   (with-new-def (dexp alg *number-types-dumped*)
  81.     (when (not (def-prelude? alg))
  82.       (setf dexp (def-dump-index alg)))
  83.     (mlet (((file line) (dump-source-pointer (def-where-defined alg))))
  84.      (add-dump-init
  85.       `(init-algdata-slots
  86.      ,dexp
  87.      ,(def-exported? alg)
  88.      ,(algdata-arity alg)
  89.      ,(algdata-n-constr alg)
  90.      ,(dump-object (algdata-constrs alg))
  91.  
  92.      ,(dump-object (algdata-context alg))
  93.      ,(dump-object (algdata-tyvars alg))
  94.      ,(dump-object (algdata-signature alg))
  95.      ,(algdata-enum? alg)
  96.      ,(algdata-tuple? alg)
  97.  
  98.      ,(algdata-real-tuple? alg)
  99.      ,(algdata-implemented-by-lisp? alg)
  100.      ,(dump-object (algdata-runtime-var alg))
  101.      ',file
  102.      ',line)
  103.       ))))
  104.         
  105.  
  106. (define-walker-method dump synonym (syn)
  107.   (dump-synonym/n syn))
  108.  
  109. (define (dump-synonym/n syn)
  110.   (with-new-def (dexp syn *number-types-dumped*)
  111.     (when (not (def-prelude? syn))
  112.       (setf dexp (def-dump-index syn)))
  113.     (mlet (((file line) (dump-source-pointer (def-where-defined syn))))
  114.      (add-dump-init
  115.       `(init-synonym-slots
  116.          ,dexp
  117.      ,(def-exported? syn)
  118.      ,(synonym-arity syn)
  119.      ,(dump-object (synonym-args syn))
  120.      ,(dump-object (synonym-body syn))
  121.      ',file
  122.      ',line)
  123.       ))))
  124.  
  125. (define-walker-method dump deriving (deriving)
  126.   (dump-deriving/n deriving))
  127.  
  128. (define (dump-deriving/n deriving)
  129.   (with-new-def (dexp deriving *number-types-dumped*)
  130.     (when (not (def-prelude? deriving))
  131.       (setf dexp (def-dump-index deriving)))
  132.     (add-dump-init
  133.       `(init-deriving-slots
  134.          ,dexp
  135.      ,(dump-object (deriving-preconditions deriving))
  136.      ,(dump-object (deriving-instances deriving))
  137.       ))))
  138.  
  139. (define-walker-method dump class (class)
  140.   (dump-class/n class))
  141.  
  142. (define (dump-class/n class)
  143.   (with-new-def (dexp class *number-classes-dumped*)
  144.     (when (not (def-prelude? class))
  145.       (setf dexp (def-dump-index class)))
  146.     (mlet (((file line) (dump-source-pointer (def-where-defined class))))
  147.      (add-dump-init
  148.       `(init-class-slots
  149.      ,dexp
  150.      ,(dump-object (def-exported? class))
  151.      ,(dump-object (class-super class))
  152.      ,(dump-object (class-super* class))
  153.      ,(dump-object (class-tyvar class))
  154.      ,(dump-object (class-method-vars class))
  155.  
  156.      ,(dump-object (class-selectors class))
  157.      ,(dump-object (class-kind class))
  158.      ,(class-n-methods class)
  159.      ,(class-dict-size class)
  160.      ,(dump-object (class-runtime-var class))
  161.      
  162.      ',file
  163.      ',line))
  164.       )))
  165.  
  166. ;;; The deriving definition needs to save instance decls
  167.  
  168. (define-dumper-methods
  169.   (instance-decl (valdef depend-val dictionary-args extra-decls)
  170.    single-fun-def guarded-rhs as-pat irr-pat var-pat wildcard-pat
  171.    const-pat plus-pat pcon list-pat dynamic-pat lambda let if case
  172.    (alt test) exp-sign app con-ref integer-const char-const
  173.    string-const list-exp sequence omitted-guard))
  174.  
  175. (define-walker-method dump var-ref (var)
  176.   (if (eq? (var-ref-var var) *undefined-def*)
  177.       `(**var ',(var-ref-name var))
  178.       `(**var/def ,(dump-object (var-ref-var var)))))
  179.     
  180.  
  181.  
  182. ;;;==================================================================
  183. ;;; Dumpers for type-related structs
  184. ;;;==================================================================
  185.  
  186. ;;; This section contains dumpers to handle type-related structs that
  187. ;;; are referenced by the various def guys.
  188.  
  189.  
  190. (define-walker-method dump instance (o)
  191.   (if (not (instance-ok? o))
  192.       (error "Attempt to dump instance that's not ok!"))
  193.   (mlet (((file line) (dump-source-pointer (ast-node-line-number o))))
  194.      `(make-new-instance
  195.        ,(dump-object (instance-algdata o))
  196.        ,(dump-object (instance-tyvars o))
  197.        ,(dump-object (instance-class o))
  198.        ,(dump-object (instance-context o))
  199.        ,(dump-object (instance-gcontext o))
  200.  
  201.        ,(dump-object (instance-dictionary o))
  202.        ,(dump-object (instance-methods o))
  203.        ,(dump-object (instance-runtime-var o))
  204.        ',file
  205.        ',line)))
  206.  
  207. (define-walker-method dump gtype (o)
  208.   (let ((context  (gtype-context o))
  209.     (type     (dump-gtype-type (gtype-type o))))
  210.     (if (every (function null?) context)
  211.     `(gtype/null ,(length context) ,type)
  212.     `(gtype/n (list ,@(map (function dump-class-list) context)) ,type))))
  213.  
  214. (define (dump-class-list o)
  215.   `(list ,@(map (function dump-class/n) o)))
  216.  
  217. (define (dump-gtype-type o)
  218.   (let* ((code   (dump-gtype-type-aux o))
  219.      (entry  (assoc code *dump-types*)))
  220.     (when (not entry)
  221.       (push (setf entry (cons code *dump-type-counter*)) *dump-types*)
  222.       (incf *dump-type-counter*))
  223.     (cdr entry)))
  224.  
  225. (define (dump-gtype-type-aux o)
  226.   (cond ((gtyvar? o)
  227.      `(**gtyvar ,(gtyvar-varnum o)))
  228.     ((ntyvar? o)
  229.      (dump-gtype-type-aux (prune o)))
  230.     (else
  231.      (dump-ntycon o))))
  232.  
  233. (define (dump-ntycon o)
  234.   (let* ((tycon  (ntycon-tycon o))
  235.      (stuff  (if (algdata? tycon)
  236.              (dump-algdata/n tycon)
  237.              (dump-synonym/n tycon)))
  238.      (args   (ntycon-args o)))
  239.     (cond ((eq? tycon (core-symbol "Arrow"))
  240.        (dump-arrow-ntycon
  241.          (list (dump-gtype-type (car args)))
  242.          (cadr args)))
  243.       ((eq? tycon (core-symbol "List"))
  244.        `(list/n ,(dump-gtype-type (car args))))
  245.       ((not (def-prelude? tycon))
  246.        `(ntycon/def-n ,(def-dump-index tycon)
  247.               ,@(map (function dump-gtype-type) args)))
  248.       (else
  249.        `(ntycon/def ,stuff
  250.             ,@(map (function dump-gtype-type) args)))
  251.       )))
  252.  
  253. (define (dump-arrow-ntycon head next)
  254.   (if (and (ntycon? next)
  255.        (eq? (ntycon-tycon next) (core-symbol "Arrow")))
  256.       (let ((args  (ntycon-args next)))
  257.     (dump-arrow-ntycon
  258.       (cons (dump-gtype-type (car args)) head)
  259.       (cadr args)))
  260.       `(arrow/n ,@(nreverse head) ,(dump-gtype-type next))))
  261.  
  262.  
  263. (define-walker-method dump fixity (o)
  264.   `(**fixity ',(fixity-associativity o) ,(fixity-precedence o)))
  265.  
  266. (define-walker-method dump class-ref (o)
  267.   `(**class/def ,(dump-object (class-ref-class o))))
  268.  
  269. (define-walker-method dump context (o)
  270.   (let* ((class (class-ref-class (context-class o)))
  271.      (tyvar (context-tyvar o))
  272.      (stuff (dump-object class)))
  273.     (if (def-prelude? class)
  274.     `(context/def ,stuff ,(dump-object tyvar))
  275.     `(context/def-n ,(def-dump-index class) ,(dump-object tyvar)))))
  276.  
  277. (define-walker-method dump tyvar (o)
  278.   `(**tyvar ',(tyvar-name o)))
  279.  
  280.  
  281. ;;; Use this shorthand for tyvars in tycon/def and friends.
  282.  
  283. (define (dump-type o)
  284.   (if (tyvar? o)
  285.       `',(tyvar-name o)
  286.       (dump-object o)))
  287.  
  288. (define-walker-method dump tycon (o)
  289.   (let ((def   (tycon-def o))
  290.     (args  (tycon-args o)))
  291.     (if (eq? def (core-symbol "Arrow"))
  292.     (dump-arrow-tycon (list (dump-type (car args))) (cadr args))
  293.     (let ((stuff     (dump-object def))
  294.           (arg-code  (map (function dump-type) args)))
  295.       (if (def-prelude? def)
  296.           `(tycon/def ,stuff ,@arg-code)
  297.           `(tycon/def-n ,(def-dump-index def) ,@arg-code))))))
  298.  
  299. (define (dump-arrow-tycon head next)
  300.   (if (and (tycon? next)
  301.        (eq? (tycon-def next) (core-symbol "Arrow")))
  302.       (let ((args  (tycon-args next)))
  303.     (dump-arrow-tycon
  304.       (cons (dump-type (car args)) head)
  305.       (cadr args)))
  306.       `(tycon/arrow ,@(nreverse head) ,(dump-type next))))
  307.  
  308.  
  309. (define-walker-method dump default-decl (o)
  310.   `(make default-decl (types ,(dump-object (default-decl-types o)))))
  311.  
  312. (define-walker-method dump signature (o)
  313.   `(make-sig ,(dump-object (signature-context o))
  314.          ,(dump-object (signature-type o))))
  315.  
  316. ;;; All ntyvars should be instantiated at this point
  317.  
  318. ; (define-walker-method dump ntyvar (o)
  319. ;  (dump-object (prune o)))
  320.  
  321.  
  322.  
  323. ;;;==================================================================
  324. ;;; Dumpers for strictness
  325. ;;;==================================================================
  326.  
  327. ;;; Precompute and cache argument strictness lists in a table.
  328.  
  329. (define *pre-defined-strictness-size* 7)  ; length of max strictness list
  330. (define *pre-defined-strictness-table*
  331.   (let* ((size  (expt 2 (1+ (dynamic *pre-defined-strictness-size*))))
  332.      (table (make-vector size)))
  333.     (setf (vector-ref table 1) '())
  334.     (do ((i 1 (1+ i))
  335.      (j 1 (* j 2))
  336.      (k 2 (* k 2)))
  337.     ((> i *pre-defined-strictness-size*))
  338.     (do ((l 0 (1+ l)))
  339.         ((>= l j))
  340.         (setf (vector-ref table (+ k l))
  341.           (cons '#f (vector-ref table (+ j l))))
  342.         (setf (vector-ref table (+ k j l))
  343.           (cons '#t (vector-ref table (+ j l))))))
  344.     table))
  345.  
  346. (define (dump-strictness s)
  347.   (if (null? s)
  348.       ''()
  349.       (dump-strictness-1 s s 0 0)))
  350.  
  351. (define (dump-strictness-1 s s1 n size)
  352.   (if (null? s1)
  353.       (if (> size *pre-defined-strictness-size*)
  354.       (dump-big-strictness (- size *pre-defined-strictness-size*) s)
  355.       (let ((k (+ n (expt 2 size))))
  356.         `(strictness-n ,k)))
  357.       (dump-strictness-1 s (cdr s1) (+ (* 2 n) (if (car s1) 1 0)) (1+ size))))
  358.  
  359. (define (dump-big-strictness k s)
  360.   (if (= k 0)
  361.       (dump-strictness s)
  362.       `(cons ',(car s)
  363.          ,(dump-big-strictness (1- k) (cdr s)))))
  364.  
  365.  
  366. ;;; Runtime support for the above
  367.  
  368. (define (strictness-n x)
  369.   (vector-ref (dynamic *pre-defined-strictness-table*) x))
  370.  
  371.  
  372.  
  373.  
  374. ;;;==================================================================
  375. ;;; Runtime support functions
  376. ;;;==================================================================
  377.  
  378. (define (lookup-imported-mod i)
  379.   (vector-ref *modules-imported* i))
  380.  
  381. (define (lookup-defined-mod i)
  382.   (vector-ref *modules-loaded* i))
  383.  
  384. (define (interface-def/n sym indices)
  385.   (cons sym (map (function def-n) indices)))
  386.  
  387. (define (def-n i)
  388.   (vector-ref *defs-referenced* i))
  389.  
  390. (define (set-def-n/method-var i module name)
  391.   (setf (vector-ref *defs-referenced* i)
  392.     (create-definition/inner
  393.       (if (symbol? module)
  394.           module
  395.           (module-name (lookup-defined-mod module)))
  396.       name
  397.       'method-var)))
  398.  
  399. (define (set-def-n/var i module name)
  400.   (setf (vector-ref *defs-referenced* i)
  401.     (create-definition/inner
  402.       (if (symbol? module)
  403.           module
  404.           (module-name (lookup-defined-mod module)))
  405.       name
  406.       'var)))
  407.  
  408. (define (set-def-n/con i module name)
  409.   (setf (vector-ref *defs-referenced* i)
  410.     (create-definition/inner
  411.       (if (symbol? module)
  412.           module
  413.           (module-name (lookup-defined-mod module)))
  414.       name
  415.       'con)))
  416.  
  417. (define (set-def-n/synonym i module name)
  418.   (setf (vector-ref *defs-referenced* i)
  419.     (create-definition/inner
  420.       (if (symbol? module)
  421.           module
  422.           (module-name (lookup-defined-mod module)))
  423.       name
  424.       'synonym)))
  425.  
  426. (define (set-def-n/deriving i module name)
  427.   (setf (vector-ref *defs-referenced* i)
  428.     (create-definition/inner
  429.       (if (symbol? module)
  430.           module
  431.           (module-name (lookup-defined-mod module)))
  432.       name
  433.       'di)))
  434.  
  435. (define (set-def-n/algdata i module name)
  436.   (setf (vector-ref *defs-referenced* i)
  437.     (create-definition/inner
  438.       (if (symbol? module)
  439.           module
  440.           (module-name (lookup-defined-mod module)))
  441.       name
  442.       'algdata)))
  443.  
  444. (define (set-def-n/class i module name)
  445.   (setf (vector-ref *defs-referenced* i)
  446.     (create-definition/inner
  447.       (if (symbol? module)
  448.           module
  449.           (module-name (lookup-defined-mod module)))
  450.       name
  451.       'class)))
  452.  
  453. (define (set-def-n/tuple-con i arity)
  454.   (setf (vector-ref *defs-referenced* i)
  455.     (tuple-constructor arity)))
  456.  
  457. (define (set-def-n/tuple-tycon i arity)
  458.   (setf (vector-ref *defs-referenced* i)
  459.     (tuple-tycon arity)))
  460.  
  461. (define (set-def-n/import i module-index name)
  462.   (setf (vector-ref *defs-referenced* i)
  463.     (table-entry (module-symbol-table (lookup-imported-mod module-index))
  464.              name)))
  465.  
  466.  
  467. (define (type-n i)
  468.   (vector-ref *types-referenced* i))
  469.  
  470. (define (set-type-n i value)
  471.   (setf (vector-ref *types-referenced* i) value))
  472.  
  473.  
  474. (define (set-export/def-n table index)
  475.   (let* ((def (vector-ref *defs-referenced* index))
  476.      (key (def-name def)))
  477.     (setf (table-entry table key)
  478.       (list (cons key def)))))
  479.  
  480. (define (set-export/def-n/list table indices)
  481.   (dolist (index indices)
  482.     (let* ((def (vector-ref *defs-referenced* index))
  483.        (key (def-name def)))
  484.       (setf (table-entry table key)
  485.         (list (cons key def))))))
  486.  
  487. (define (set-export/def-n/key table index key)
  488.   (let ((def (vector-ref *defs-referenced* index)))
  489.     (setf (table-entry table key)
  490.       (list (cons key def)))))
  491.  
  492. (define (set-export/def table def)
  493.   (let ((key  (def-name def)))
  494.     (setf (table-entry table key)
  495.       (list (cons key def)))))
  496.  
  497. (define (set-export/def/key table def key)
  498.   (setf (table-entry table key)
  499.     (list (cons key def))))
  500.  
  501.  
  502. (define (set-symtab/def-n table index)
  503.   (let ((def  (vector-ref *defs-referenced* index)))
  504.     (setf (table-entry table (def-name def)) def)))
  505.  
  506. (define (set-symtab/def-n/list table indices)
  507.   (dolist (index indices)
  508.     (let ((def  (vector-ref *defs-referenced* index)))
  509.       (setf (table-entry table (def-name def)) def))))
  510.  
  511. (define (set-symtab/def-n/key table index key)
  512.   (let ((def  (vector-ref *defs-referenced* index)))
  513.     (setf (table-entry table key) def)))
  514.  
  515. (define (set-symtab/def table def)
  516.   (setf (table-entry table (def-name def)) def))
  517.  
  518. (define (set-symtab/def/key table def key)
  519.   (setf (table-entry table key) def))
  520.     
  521.  
  522. (define (make-fixity-table data)
  523.   (let ((table  (make-table)))
  524.     (dolist (d data)
  525.       (let ((key  (car d))
  526.         (ass  (cadr d))
  527.         (prec (caddr d)))
  528.     (setf (table-entry table key)
  529.           (make fixity (associativity ass) (precedence prec)))))
  530.     table))
  531.  
  532.  
  533. (define (init-var-slots
  534.      var exported? toplevel? type simple?
  535.      strict? file line)
  536.   (when (integer? var) (setf var (def-n var)))
  537.   (setf (def-exported? var) exported?)
  538.   (setf (var-toplevel? var) toplevel?)
  539.   (setf (var-type var) type)
  540.   (setf (var-simple? var) simple?)
  541.   (setf (var-strict? var) strict?)
  542.   (setf (def-where-defined var) (restore-source-pointer file line))
  543.   var)
  544.  
  545. (define (init-fn-slots
  546.         var exported? toplevel? type simple?
  547.         strict? arity strictness opt-entry file
  548.         line)
  549.   (when (integer? var) (setf var (def-n var)))
  550.   (setf (def-exported? var) exported?)
  551.   (setf (var-toplevel? var) toplevel?)
  552.   (setf (var-type var) type)
  553.   (setf (var-simple? var) simple?)
  554.   (setf (var-strict? var) strict?)
  555.   (setf (var-arity var) arity)
  556.   (setf (var-strictness var) strictness)
  557.   (setf (var-optimized-entry var) opt-entry)
  558.   (setf (def-where-defined var) (restore-source-pointer file line))
  559.   var)
  560.  
  561. (define (set-var-selector-fn? var value)
  562.   (when (integer? var) (setf var (def-n var)))
  563.   (setf (var-selector-fn? var) value))
  564.  
  565. (define (set-var-always-inline? var value)
  566.   (when (integer? var) (setf var (def-n var)))
  567.   (setf (var-always-inline? var) value))
  568.  
  569. (define (set-var-complexity var value)
  570.   (when (integer? var) (setf var (def-n var)))
  571.   (setf (var-complexity var) value))
  572.  
  573. (define (set-var-fixity var ass prec)
  574.   (when (integer? var) (setf var (def-n var)))
  575.   (setf (var-fixity var) (**fixity ass prec)))
  576.  
  577. (define (set-var-value var value)
  578.   (when (integer? var) (setf var (def-n var)))
  579.   (setf (var-value var) value))
  580.  
  581. (define (set-var-inline-value var value)
  582.   (when (integer? var) (setf var (def-n var)))
  583.   (setf (var-inline-value var) value))
  584.  
  585. (define (set-var-specializers var value)
  586.   (when (integer? var) (setf var (def-n var)))
  587.   (setf (var-specializers var) value))
  588.  
  589. (define (init-method-var-slots
  590.      var class default method-signature)
  591.   (when (integer? var) (setf var (def-n var)))
  592.   (setf (method-var-class var) class)
  593.   (setf (method-var-default var) default)
  594.   (setf (method-var-method-signature var) method-signature)
  595.   var)
  596.  
  597. (define (init-con-slots
  598.        con arity types signature tag
  599.        alg fixity infix? file line)
  600.   (when (integer? con) (setf con (def-n con)))
  601.   (setf (con-arity con) arity)
  602.   (setf (con-types con) types)
  603.   (setf (con-signature con) signature)
  604.   (setf (con-tag con) tag)
  605.   (setf (con-alg con) alg)
  606.   (setf (con-fixity con) fixity)
  607.   (setf (con-infix? con) infix?)
  608.   (when (null? (con-slot-strict? con))
  609.     (dotimes (i arity)
  610.       (push '#f (con-slot-strict? con))))
  611.   (setf (def-where-defined con) (restore-source-pointer file line))
  612.   con)
  613.  
  614. (define (set-con-slot-strict? con value)
  615.   (when (integer? con) (setf con (def-n con)))
  616.   (setf (con-slot-strict? con) value))
  617.  
  618. (define (set-con-lisp-fns con value)
  619.   (when (integer? con) (setf con (def-n con)))
  620.   (setf (con-lisp-fns con) value))
  621.   
  622.  
  623. (define (init-algdata-slots
  624.        alg exported? arity n-constr constrs context
  625.        tyvars signature enum? tuple? real-tuple?
  626.        implemented-by-lisp? r file line)
  627.   (when (integer? alg) (setf alg (def-n alg)))
  628.   (setf (def-exported? alg) exported?)
  629.   (setf (algdata-arity alg) arity)
  630.   (setf (algdata-n-constr alg) n-constr)
  631.   (setf (algdata-constrs alg) constrs)
  632.   (setf (algdata-context alg) context)
  633.   (setf (algdata-tyvars alg) tyvars)
  634.   (setf (algdata-signature alg) signature)
  635.   (setf (algdata-enum? alg) enum?)
  636.   (setf (algdata-tuple? alg) tuple?)
  637.   (setf (algdata-real-tuple? alg) real-tuple?)
  638.   (setf (algdata-implemented-by-lisp? alg) implemented-by-lisp?)
  639.   (setf (algdata-runtime-var alg) r)
  640.   (setf (def-where-defined alg) (restore-source-pointer file line))
  641.   alg)
  642.  
  643. (define (init-synonym-slots
  644.       syn exported? arity args body
  645.       file line)
  646.   (when (integer? syn) (setf syn (def-n syn)))
  647.   (setf (def-exported? syn) exported?)
  648.   (setf (synonym-arity syn) arity)
  649.   (setf (synonym-args syn) args)
  650.   (setf (synonym-body syn) body)
  651.   (setf (def-where-defined syn) (restore-source-pointer file line))
  652.   syn)
  653.  
  654. (define (init-deriving-slots deriving classes insts)
  655.   (when (integer? deriving) (setf deriving (def-n deriving)))
  656.   (setf (deriving-preconditions deriving) classes)
  657.   (setf (deriving-instances deriving) insts)
  658.   deriving)
  659.  
  660. (define (init-class-slots
  661.        class exported? super super* tyvar
  662.        method-vars selectors kind n-methods dict-size
  663.        r file line)
  664.   (when (integer? class) (setf class (def-n class)))
  665.   (setf (def-exported? class) exported?)
  666.   (setf (class-super class) super)
  667.   (setf (class-super* class) super*)
  668.   (setf (class-tyvar class) tyvar)
  669.   (setf (class-method-vars class) method-vars)
  670.   (setf (class-selectors class) selectors)
  671.   (setf (class-kind class) kind)
  672.   (setf (class-n-methods class) n-methods)
  673.   (setf (class-dict-size class) dict-size)
  674.   (setf (class-runtime-var class) r)
  675.   (setf (def-where-defined class) (restore-source-pointer file line))
  676.   class)
  677.   
  678.  
  679. (define (make-new-instance
  680.        algdata tyvars class context gcontext
  681.        dictionary m r file line)
  682.   (make instance
  683.     (algdata algdata)
  684.     (tyvars tyvars)
  685.     (class class)
  686.     (context context)
  687.     (gcontext gcontext)
  688.     (dictionary dictionary)
  689.     (methods m)
  690.     (ok? '#t)
  691.     (runtime-var r)
  692.     (line-number (restore-source-pointer file line))))
  693.  
  694. (define (tycon/arrow . args)
  695.   (**arrow-type/l (map (function munge-tyvar) args)))
  696.  
  697. (define (tycon/def def . args)
  698.   (**tycon/def def (map (function munge-tyvar) args)))
  699.  
  700. (define (tycon/def-n n . args)
  701.   (**tycon/def (def-n n) (map (function munge-tyvar) args)))
  702.  
  703. (define (munge-tyvar arg)
  704.   (if (symbol? arg)
  705.       (**tyvar arg)
  706.       arg))
  707.  
  708. (define (context/def def tyvar)
  709.   (**context (**class/def def) tyvar))
  710.  
  711. (define (context/def-n n tyvar)
  712.   (**context (**class/def (def-n n)) tyvar))
  713.  
  714. (define (make-sig context type)
  715.   (make signature (context context) (type type)))
  716.  
  717.  
  718.  
  719. ;;; All of these constructors for type-related objects permit an integer
  720. ;;; index into the type vector as a type argument, as well as real
  721. ;;; type objects.
  722.  
  723. (define (gtype/null n arg)
  724.   (**gtype (make-list n '()) (expand-type arg)))
  725.  
  726. (define (gtype/n context arg)
  727.   (**gtype context (expand-type arg)))
  728.  
  729. (define (ntycon/def-n n . args)
  730.   (**ntycon (def-n n) (expand-types args)))
  731.  
  732. (define (ntycon/def def . args)
  733.   (**ntycon def (expand-types args)))
  734.  
  735. (define (arrow/n . args)
  736.   (**arrow/l (expand-types args)))
  737.  
  738. (define (list/n arg)
  739.   (**list-of (expand-type arg)))
  740.  
  741. (define (expand-types args)
  742.   (map (function expand-type) args))
  743.  
  744. (define (expand-type arg)
  745.   (if (integer? arg)
  746.       (type-n arg)
  747.       arg))
  748.  
  749. ;;; Stuff to support saving definition points
  750.  
  751. (define (dump-source-pointer sp)
  752.   (if sp
  753.       (values
  754.        (dump-file-name (source-pointer-file sp)) (source-pointer-line sp))
  755.       (values '#f '#f)))  
  756.  
  757. (define (dump-file-name str)
  758.   (dump-file-name-1 str *dump-file-names* 0))
  759.  
  760. (define (dump-file-name-1 str names i)
  761.   (cond ((null? names)
  762.      (setf *dump-file-names* (append *dump-file-names* (list str)))
  763.      i)
  764.     ((eq? str (car names))
  765.      i)
  766.     (else (dump-file-name-1 str (cdr names) (1+ i)))))
  767.  
  768. (define (restore-source-pointer file line)
  769.   (if file
  770.       (make source-pointer (file (list-ref *dump-file-names* file))
  771.         (line line))
  772.       '#f))
  773.