home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / flic / print-flic.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  4.2 KB  |  144 lines  |  [TEXT/CCL2]
  1. ;;; print-flic.scm -- printers for FLIC structures
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  30 Mar 1992
  5. ;;;
  6. ;;;
  7.  
  8.  
  9. ;;; For now, printing of FLIC structures is controlled by the same
  10. ;;; *print-ast-syntax* variable as for AST structures.
  11. ;;; Maybe eventually this should use its own variable.
  12.  
  13. (define-syntax (define-flic-printer type lambda-list . body)
  14.   `(define-ast-printer ,type ,lambda-list ,@body))
  15.  
  16. (define-flic-printer flic-lambda (object xp)
  17.   (with-ast-block (xp)
  18.     (write-string "\\ " xp)
  19.     (write-ordinary-list (flic-lambda-vars object) xp)
  20.     (write-string " ->" xp)
  21.     (write-whitespace xp)
  22.     (write (flic-lambda-body object) xp)))
  23.  
  24. (define-flic-printer flic-let (object xp)
  25.   (pprint-logical-block (xp '() "" "")  ; no extra indentation
  26.     (write-string "let " xp)
  27.     (write-layout-rule (flic-let-bindings object) xp
  28.                (lambda (v xp)
  29.                  (with-ast-block (xp)
  30.                    (write v xp)
  31.                (write-string " =" xp)
  32.                (write-whitespace xp)
  33.                (write (var-value v) xp))))
  34.     (write-whitespace xp)
  35.     (write-string "in " xp)
  36.     (write (flic-let-body object) xp)))
  37.  
  38. (define-flic-printer flic-app (object xp)
  39.   (with-ast-block (xp)
  40.     (maybe-paren-flic-object (flic-app-fn object) xp)
  41.     (write-whitespace xp)
  42.     (write-flic-list (flic-app-args object) xp)))
  43.  
  44. (define (maybe-paren-flic-object object xp)
  45.   (cond ((or (flic-ref? object)
  46.          (flic-const? object)
  47.          (flic-pack? object))
  48.      (write object xp))
  49.     (else
  50.      (write-char #\( xp)
  51.      (write object xp)
  52.      (write-char #\) xp))))
  53.  
  54. (define (write-flic-list objects xp)
  55.   (write-delimited-list objects xp (function maybe-paren-flic-object) "" "" ""))
  56.  
  57. (define-flic-printer flic-ref (object xp)
  58.   (write (flic-ref-var object) xp))
  59.  
  60. (define-flic-printer flic-const (object xp)
  61.   (write (flic-const-value object) xp))
  62.  
  63. (define-flic-printer flic-pack (object xp)
  64.   (write-string "pack/" xp)
  65.   (write (flic-pack-con object) xp))
  66.  
  67. (define-flic-printer flic-case-block (object xp)
  68.   (with-ast-block (xp)
  69.     (write-string "case-block " xp)
  70.     (write (flic-case-block-block-name object) xp)
  71.     (write-whitespace xp)
  72.     (write-layout-rule (flic-case-block-exps object) xp (function write))))
  73.  
  74. (define-flic-printer flic-return-from (object xp)
  75.   (with-ast-block (xp)
  76.     (write-string "return-from " xp)
  77.     (write (flic-return-from-block-name object) xp)
  78.     (write-whitespace xp)
  79.     (write (flic-return-from-exp object) xp)))
  80.  
  81. (define-flic-printer flic-and (object xp)
  82.   (with-ast-block (xp)
  83.     (write-string "and " xp)
  84.     (write-layout-rule (flic-and-exps object) xp (function write))))
  85.  
  86. (define-flic-printer flic-if (object xp)
  87.   (with-ast-block (xp)
  88.     (write-string "if " xp)
  89.     (write (flic-if-test-exp object) xp)
  90.     (write-whitespace xp)
  91.     (with-ast-block (xp)
  92.       (write-string "then" xp)
  93.       (write-whitespace xp)
  94.       (write (flic-if-then-exp object) xp))
  95.     (write-whitespace xp)
  96.     (with-ast-block (xp)
  97.       (write-string "else" xp)
  98.       (write-whitespace xp)
  99.       (write (flic-if-else-exp object) xp))
  100.     ))
  101.  
  102.  
  103. (define-flic-printer flic-sel (object xp)
  104.   (with-ast-block (xp)
  105.     (write-string "sel/" xp)
  106.     (write (flic-sel-con object) xp)
  107.     (write-char #\/ xp)
  108.     (write (flic-sel-i object) xp)
  109.     (write-whitespace xp)
  110.     (write (flic-sel-exp object) xp)))
  111.  
  112. (define-flic-printer flic-is-constructor (object xp)
  113.   (with-ast-block (xp)
  114.     (write-string "is-constructor/" xp)
  115.     (write (flic-is-constructor-con object) xp)
  116.     (write-whitespace xp)
  117.     (write (flic-is-constructor-exp object) xp)))
  118.  
  119. (define-flic-printer flic-con-number (object xp)
  120.   (with-ast-block (xp)
  121.     (write-string "con/" xp)
  122.     (write (flic-con-number-type object) xp)
  123.     (write-whitespace xp)
  124.     (write (flic-con-number-exp object) xp)))
  125.  
  126. (define-flic-printer flic-void (object xp)
  127.   (declare (ignore object))
  128.   (write-string "Void" xp))
  129.  
  130.  
  131. (define-flic-printer flic-update (object xp)
  132.   (with-ast-block (xp)
  133.     (write-string "(update/" xp)
  134.     (write (flic-update-con object) xp)
  135.     (dolist (s (flic-update-slots object))
  136.       (write-string "(" xp)
  137.       (write (car s) xp)
  138.       (write-string "=" xp)
  139.       (write (cdr s) xp)
  140.       (write-string ")" xp)
  141.       (write-whitespace xp))
  142.     (write (flic-update-exp object))
  143.     (write-string ")" xp)))
  144.