home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-386-Vol-2of3.iso / c / cr-macro.zip / EXPAND.SCM < prev    next >
Text File  |  1990-02-16  |  6KB  |  194 lines
  1. ; Translate Scheme to Scheme, expanding macros and alpha-converting
  2.  
  3. (define (expand exp env)
  4.   (classify exp env perform-expansion))
  5.  
  6. (define (expand-list exp-list env)
  7.   (map (lambda (exp) (expand exp env))
  8.        exp-list))
  9.  
  10. (define (perform-expansion class exp env)
  11.   ((vector-ref expansion-procedures class) exp env))
  12.  
  13. (define (expand-literal exp env) exp)
  14.  
  15. (define (expand-variable exp env)
  16.   (let ((binding (lookup-variable exp env)))
  17.     (cond ((symbol? binding) binding)
  18.       ((unbound? binding)
  19.        (unbound-name binding))
  20.       (else (error "invalid binding" binding)))))
  21.  
  22. (define (expand-application exp env)
  23.   (classify (operator exp) env
  24.     (lambda (class op-exp op-env)
  25.       (if (= class class/lambda)
  26.       (let* ((formals (lambda-formals op-exp))
  27.          (body-env (bind-variables (normalize-formals formals)
  28.                        op-env)))
  29.         `(let ,(map list
  30.             (rename-formals formals body-env)
  31.             (expand-list (operands exp) env))
  32.            ,(expand-body (lambda-body op-exp) body-env)))
  33.       (cons (perform-expansion class op-exp op-env)
  34.         (expand-list (operands exp) env))))))
  35.  
  36. (define (expand-lambda exp env)
  37.   (let* ((formals (lambda-formals exp))
  38.      (env (bind-variables (normalize-formals formals)
  39.                   env)))
  40.     `(lambda ,(rename-formals formals env)
  41.        ,(expand-body (lambda-body exp) env))))
  42.  
  43. (define (rename-formals formals env)
  44.   (cond ((null? formals) '())
  45.     ((pair? formals)
  46.      (cons (lookup-variable (car formals) env)
  47.            (rename-formals (cdr formals) env)))
  48.     (else (lookup-variable formals env))))
  49.  
  50. (define (normalize-formals formals)
  51.   (cond ((null? formals) '())
  52.         ((pair? formals)
  53.      (cons (car formals) (normalize-formals (cdr formals))))
  54.         (else (list formals))))
  55.  
  56. (define (expand-letrec exp env)
  57.   (let* ((bspecs (letrec-bspecs exp))
  58.      (env (bind-variables (map bspec-name bspecs) env)))
  59.     `(letrec ,(map (lambda (bspec)
  60.              `(,(lookup-variable (bspec-name bspec) env)
  61.                ,(expand (bspec-rhs bspec) env)))
  62.            bspecs)
  63.        ,(expand-body (letrec-body exp) env))))
  64.  
  65. (define (expand-if exp env)
  66.   (let ((alt (expand (if-alternate exp) env)))
  67.     (if (equal? alt unspecified-expression)
  68.     `(if ,(expand (if-test exp) env)
  69.          ,(expand (if-consequent exp) env))
  70.     `(if ,(expand (if-test exp) env)
  71.          ,(expand (if-consequent exp) env)
  72.          ,alt))))
  73.  
  74. (define (expand-quote exp env)
  75.   `',(unpaint (quotation-text exp)))
  76.  
  77. (define (expand-begin exp env)
  78.   `(begin ,@(expand-list (begin-statements exp) env)))
  79.  
  80. (define (expand-set! exp env)
  81.   `(set! ,(expand-variable (set!-lhs exp) env)
  82.      ,(expand (set!-rhs exp) env)))
  83.  
  84. (define (expand-let-syntax exp env)
  85.   (classify-let-syntax    exp env perform-expansion))
  86.  
  87. (define (expand-letrec-syntax exp env)
  88.   (classify-letrec-syntax exp env perform-expansion))
  89.  
  90. (define (expand-invalid-context exp env)
  91.   (syntax-error "form not appropriate in expression context" exp))
  92.  
  93. (define expansion-procedures
  94.   (let ((v (make-vector number-of-classes expand-invalid-context)))
  95.     (vector-set! v class/literal       expand-literal)
  96.     (vector-set! v class/variable      expand-variable)
  97.     (vector-set! v class/application   expand-application)
  98.     (vector-set! v class/lambda        expand-lambda)
  99.     (vector-set! v class/letrec        expand-letrec)
  100.     (vector-set! v class/if            expand-if)
  101.     (vector-set! v class/quote         expand-quote)
  102.     (vector-set! v class/begin         expand-begin)
  103.     (vector-set! v class/set!          expand-set!)
  104.     (vector-set! v class/let-syntax    expand-let-syntax)
  105.     (vector-set! v class/letrec-syntax expand-letrec-syntax)
  106.     v))
  107.  
  108. (define *counter* 0)
  109.  
  110. (define (bind-variables names env)
  111.   (if (null? names)
  112.       env
  113.       (begin (set! *counter* (+ *counter* 1))
  114.          (let ((suffix (number->string *counter* '(heur))))
  115.            (bind names
  116.              (map (lambda (name)
  117.                 (string->symbol (string-append "."
  118.                                (symbol->string (name->symbol name))
  119.                                "."
  120.                                suffix)))
  121.               names)
  122.              env)))))
  123.  
  124. (define (make-name-generator)
  125.   ;; Don't bump counter if no names are generated
  126.   (let ((color (delay (new-color))))
  127.     (lambda (name)
  128.       (make-painted name (force color)))))
  129.  
  130. ; Process a lambda or letrec body
  131.  
  132. (define (expand-body body env)
  133.   (scan-body body env 
  134.     (lambda (names ds exps)
  135.       (let* ((env (bind-variables names env))
  136.          (beg (if (null? (cdr exps))
  137.               (expand (car exps) env)
  138.               `(begin ,@(expand-list exps env)))))
  139.     (if (null? names)
  140.         beg
  141.         `(letrec ,(map (lambda (name d)
  142.                  `(,(lookup name env)
  143.                    ,(d env perform-expansion)))
  144.                names
  145.                ds)
  146.            ,beg))))))
  147.  
  148. ; Top level processing
  149.  
  150. (define expand-top
  151.   (lambda (form env)
  152.     (classify form env perform-expansion-top)))
  153.  
  154. (define (perform-expansion-top class form env)
  155.   (cond ((= class class/define)
  156.      (let ((name (define-name form)))
  157.        (environment-define! env name (name->symbol name))
  158.        `(define ,name ,(expand (define-rhs form) env))))
  159.     ((= class class/define-syntax)
  160.      (environment-define! env 
  161.                   (define-syntax-name form)
  162.                   (process-syntax-binding (define-syntax-rhs form)
  163.                               env))
  164.      ''define-syntax)
  165.     ((= class class/begin)
  166.      `(begin ,@(map (lambda (form)
  167.               (expand-top form env))
  168.             (begin-statements form))))
  169.     (else (expand form env))))
  170.  
  171. ; Test routine
  172.  
  173. (define (test exp . maybe-env)
  174.   (set! *color* 0)
  175.   (set! *counter* 0)
  176.   (expand-top exp
  177.           (if (null? maybe-env)
  178.           test-environment
  179.           (car maybe-env))))
  180.  
  181. (define bare-environment
  182.   (make-mutable-environment (make-transformer-environment)))
  183.  
  184. (define-special-operators! bare-environment)
  185.  
  186. (define test-environment bare-environment)
  187.  
  188.  
  189.  
  190. ; ??? where does this belong?
  191.  
  192. ; (put 'bind 'scheme-indent-hook nil)
  193. ; (put 'classify 'scheme-indent-hook 2)
  194.