node.scm

   1 ;;;; File: "node.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
   2
   3 ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour
   4 ;;;; All Rights Reserved.
   5
   6 ;; Syntax-tree node representation.
   7
   8 (define-type node
   9   extender: define-type-of-node
  10   (parent unprintable:)
  11   children
  12 )
  13
  14 (define-type-of-node cst
  15   val
  16 )
  17
  18 (define-type-of-node ref
  19   var
  20 )
  21
  22 (define-type-of-node def
  23   var
  24 )
  25
  26 (define-type-of-node set
  27   var
  28 )
  29
  30 (define-type-of-node if
  31 )
  32
  33 (define-type-of-node prc
  34   params
  35   rest?
  36   entry-label
  37 )
  38
  39 (define-type-of-node call
  40 )
  41
  42 (define-type-of-node seq
  43 )
  44
  45 (define-type-of-node fix
  46   vars
  47 )
  48
  49 (define node->expr
  50   (lambda (node)
  51     (cond ((cst? node)
  52            (let ((val (cst-val node)))
  53              (if (self-eval? val)
  54                  val
  55                  (list 'quote val))))
  56           ((ref? node)
  57            (var-id (ref-var node)))
  58           ((def? node)
  59            (list 'define
  60                  (var-id (def-var node))
  61                  (node->expr (child1 node))))
  62           ((set? node)
  63            (list 'set!
  64                  (var-id (set-var node))
  65                  (node->expr (child1 node))))
  66           ((if? node)
  67            (list 'if
  68                  (node->expr (child1 node))
  69                  (node->expr (child2 node))
  70                  (node->expr (child3 node))))
  71           ((prc? node)
  72            (if (seq? (child1 node))
  73                (cons 'lambda
  74                      (cons (build-pattern (prc-params node) (prc-rest? node))
  75                            (nodes->exprs (node-children (child1 node)))))
  76                (list 'lambda
  77                      (build-pattern (prc-params node) (prc-rest? node))
  78                      (node->expr (child1 node)))))
  79           ((call? node)
  80            (map node->expr (node-children node)))
  81           ((seq? node)
  82            (let ((children (node-children node)))
  83              (cond ((null? children)
  84                     '(void))
  85                    ((null? (cdr children))
  86                     (node->expr (car children)))
  87                    (else
  88                     (cons 'begin
  89                           (nodes->exprs children))))))
  90           ((fix? node)
  91            (let ((children (node-children node)))
  92              (list 'letrec
  93                    (map (lambda (var val)
  94                           (list (var-id var)
  95                                 (node->expr val)))
  96                         (fix-vars node)
  97                         (take (- (length children) 1) children))
  98                    (node->expr (list-ref children (- (length children) 1))))))
  99           (else
 100            (compiler-error "unknown expression type" node)))))
 101
 102 (define nodes->exprs
 103   (lambda (nodes)
 104     (if (null? nodes)
 105         '()
 106         (if (seq? (car nodes))
 107             (append (nodes->exprs (node-children (car nodes)))
 108                     (nodes->exprs (cdr nodes)))
 109             (cons (node->expr (car nodes))
 110                   (nodes->exprs (cdr nodes)))))))
 111
 112 (define build-pattern
 113   (lambda (params rest?)
 114     (cond ((null? params)
 115            '())
 116           ((null? (cdr params))
 117            (if rest?
 118                (var-id (car params))
 119                (list (var-id (car params)))))
 120           (else
 121            (cons (var-id (car params))
 122                  (build-pattern (cdr params) rest?))))))