home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / csys / dump-flic.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  6.1 KB  |  185 lines  |  [TEXT/CCL2]
  1. ;;; dump-flic.scm -- general dump functions for flic structures
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  24 Feb 1993
  5. ;;;
  6. ;;;
  7. ;;; This stuff is used to write inline expansions to the interface file.
  8. ;;; 
  9.  
  10.  
  11. (define-flic-walker dump-flic (object var-renamings))
  12.  
  13. (define (dump-flic-list objects var-renamings)
  14.   (let ((result  '()))
  15.     (dolist (o objects)
  16.       (push (dump-flic o var-renamings) result))
  17.     `(list ,@(nreverse result))))
  18.  
  19. (define (dump-flic-top object)
  20.   (dump-flic object '()))
  21.  
  22.  
  23. (define (make-temp-bindings-for-dump oldvars var-renamings)
  24.   (let ((vars      '())
  25.     (names     '()))
  26.     (dolist (v oldvars)
  27.       (let ((name (symbol->string (def-name v)))
  28.         (temp (gensym)))
  29.     (push temp vars)
  30.         (push name names)
  31.     (push (cons v temp) var-renamings)))
  32.     (setf names (nreverse names))
  33.     (setf vars (nreverse vars))
  34.     (values vars names var-renamings)))
  35.  
  36. (define-dump-flic flic-lambda (object var-renamings)
  37.   (multiple-value-bind (vars names var-renamings)
  38.       (make-temp-bindings-for-dump (flic-lambda-vars object) var-renamings)
  39.     `(flic-lambda-hack ,vars ,names 
  40.                ,(dump-flic (flic-lambda-body object) var-renamings))
  41.     ))
  42.  
  43. (define-dump-flic flic-let (object var-renamings)
  44.   (multiple-value-bind (vars names var-renamings)
  45.       (make-temp-bindings-for-dump (flic-let-bindings object) var-renamings)
  46.     `(,(if (flic-let-recursive? object) 'flic-letrec-hack 'flic-let*-hack)
  47.       ,vars
  48.       ,names
  49.       ,(map (lambda (v) (dump-flic (var-value v) var-renamings))
  50.         (flic-let-bindings object))
  51.       ,(dump-flic (flic-let-body object) var-renamings))
  52.     ))
  53.  
  54. (define-dump-flic flic-app (object var-renamings)
  55.   (let ((fn    (dump-flic (flic-app-fn object) var-renamings))
  56.     (args  (dump-flic-list (flic-app-args object) var-renamings))
  57.     (sat?  (flic-app-saturated? object)))
  58.     ;; Try to produce more compact code.
  59.     (cond ((or (not sat?) (not (pair? fn)))
  60.        `(make-flic-app ,fn ,args ,sat?))
  61.       ((eq? (car fn) 'make-flic-ref)
  62.        `(make-flic-app/ref ,(cadr fn) ,@(cdr args)))
  63.       ((eq? (car fn) 'make-flic-ref/n)
  64.        `(make-flic-app/ref/n ,(cadr fn) ,@(cdr args)))
  65.       ((eq? (car fn) 'make-flic-pack)
  66.        `(make-flic-app/pack ,(cadr fn) ,@(cdr args)))
  67.       ((eq? (car fn) 'make-flic-pack/n)
  68.        `(make-flic-app/pack/n ,(cadr fn) ,@(cdr args)))
  69.       (else
  70.        `(make-flic-app ,fn ,args ,sat?)))))
  71.  
  72. (define-dump-flic flic-ref (object var-renamings)
  73.   (let* ((var    (flic-ref-var object))
  74.      (entry  (assq var var-renamings)))
  75.     (if entry
  76.     `(make-flic-ref ,(cdr entry))
  77.     (let ((stuff (dump-object var)))
  78.       (if (def-prelude? var)
  79.           `(make-flic-ref ,stuff)
  80.           `(make-flic-ref/n ,(def-dump-index var)))))))
  81.  
  82. (define-dump-flic flic-const (object var-renamings)
  83.   (declare (ignore var-renamings))
  84.   (let ((val  (flic-const-value object)))
  85.     (if (or (number? val) (string? val))
  86.     `(make-flic-const ,val)   ; self-evaluating
  87.     `(make-flic-const ',val))))
  88.  
  89. (define-dump-flic flic-pack (object var-renamings)
  90.   (declare (ignore var-renamings))
  91.   (let* ((con   (flic-pack-con object))
  92.      (stuff (dump-object con)))
  93.     (if (def-prelude? con)
  94.     `(make-flic-pack ,stuff)
  95.     `(make-flic-pack/n ,(def-dump-index con)))))
  96.  
  97. (define-dump-flic flic-case-block (object var-renamings)
  98.   `(make-flic-case-block
  99.      ',(flic-case-block-block-name object)
  100.      ,(dump-flic-list (flic-case-block-exps object) var-renamings)))
  101.  
  102. (define-dump-flic flic-return-from (object var-renamings)
  103.   `(make-flic-return-from
  104.      ',(flic-return-from-block-name object)
  105.      ,(dump-flic (flic-return-from-exp object) var-renamings)))
  106.  
  107. (define-dump-flic flic-and (object var-renamings)
  108.   `(make-flic-and
  109.      ,(dump-flic-list (flic-and-exps object) var-renamings)))
  110.  
  111. (define-dump-flic flic-if (object var-renamings)
  112.   `(make-flic-if
  113.      ,(dump-flic (flic-if-test-exp object) var-renamings)
  114.      ,(dump-flic (flic-if-then-exp object) var-renamings)
  115.      ,(dump-flic (flic-if-else-exp object) var-renamings)))
  116.  
  117. (define-dump-flic flic-sel (object var-renamings)
  118.   `(make-flic-sel
  119.      ,(dump-object (flic-sel-con object))
  120.      ,(flic-sel-i object)
  121.      ,(dump-flic (flic-sel-exp object) var-renamings)))
  122.  
  123. (define-dump-flic flic-is-constructor (object var-renamings)
  124.   `(make-flic-is-constructor
  125.      ,(dump-object (flic-is-constructor-con object))
  126.      ,(dump-flic (flic-is-constructor-exp object) var-renamings)))
  127.  
  128. (define-dump-flic flic-con-number (object var-renamings)
  129.   `(make-flic-con-number
  130.      ,(dump-object (flic-con-number-type object))
  131.      ,(dump-flic (flic-con-number-exp object) var-renamings)))
  132.  
  133. (define-dump-flic flic-void (object var-renamings)
  134.   (declare (ignore object var-renamings))
  135.   `(make-flic-void))
  136.  
  137. (define-dump-flic flic-update (object var-renamings)
  138.   `(make-flic-update
  139.      ,(dump-object (flic-update-con object))
  140.      (list ,@(map (lambda (s)
  141.             `(cons ,(car s) ,(dump-flic (cdr s) var-renamings)))
  142.           (flic-update-slots object)))
  143.      ,(dump-flic (flic-update-exp object) var-renamings)))
  144.  
  145.  
  146. ;;; Runtime helper functions
  147.  
  148. (define (make-flic-ref/n i)
  149.   (make-flic-ref (def-n i)))
  150.  
  151. (define (make-flic-pack/n i)
  152.   (make-flic-pack (def-n i)))
  153.  
  154. (define (make-flic-app/ref def . args)
  155.   (make-flic-app (make-flic-ref def) args '#t))
  156.  
  157. (define (make-flic-app/ref/n i . args)
  158.   (make-flic-app (make-flic-ref (def-n i)) args '#t))
  159.  
  160. (define (make-flic-app/pack def . args)
  161.   (make-flic-app (make-flic-pack def) args '#t))
  162.  
  163. (define (make-flic-app/pack/n i . args)
  164.   (make-flic-app (make-flic-pack (def-n i)) args '#t))
  165.  
  166.  
  167. (define-syntax (flic-lambda-hack temps names body)
  168.   `(let ,(map (lambda (temp name) `(,temp (create-temp-var ,name)))
  169.           temps names)
  170.      (make-flic-lambda (list ,@temps) ,body)))
  171.  
  172. (define-syntax (flic-let*-hack temps names inits body)
  173.   `(let ,(map (lambda (temp name) `(,temp (create-temp-var ,name)))
  174.           temps names)
  175.      ,@(map (lambda (temp init) `(setf (var-value ,temp) ,init)) temps inits)
  176.      (make-flic-let (list ,@temps) ,body '#f)))
  177.  
  178. (define-syntax (flic-letrec-hack temps names inits body)
  179.   `(let ,(map (lambda (temp name) `(,temp (create-temp-var ,name)))
  180.           temps names)
  181.      ,@(map (lambda (temp init) `(setf (var-value ,temp) ,init)) temps inits)
  182.      (make-flic-let (list ,@temps) ,body '#t)))
  183.  
  184.  
  185.