home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / schemify.scm < prev    next >
Encoding:
Text File  |  1991-06-11  |  3.8 KB  |  130 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; File schemify.scm / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; SCHEMIFY
  5.  
  6. ; SCHEMIFY is an inverse to alpha-conversion.
  7. ;  This generally keeps the user's original variable names whenever
  8. ;  there is no conflict.  That's the only thing the env argument is
  9. ;  used for.
  10.  
  11. (define (schemify-top node)
  12.   (schemify node '()))
  13.  
  14. (define (schemify node env)
  15.   (if (node? node)
  16.       (case (node-type node)
  17.     ((program-variable)
  18.      (program-variable-name node))
  19.     ((local-variable)
  20.      (let ((probe (assq node env)))
  21.        (if probe
  22.            (cdr probe)
  23.            (local-variable-name node))))
  24.     ((call)
  25.      (schemify-call node env))
  26.     ((constant)
  27.      (let ((val (constant-value node)))
  28.        (if (or (number? val) (char? val) (string? val) (boolean? val))
  29.            val
  30.            `',val)))
  31.     ((lambda)
  32.      (let* ((vars (lambda-vars node))
  33.         (new-vars (map (lambda (var) (externalize-variable var env))
  34.                    vars)))
  35.        `(lambda ,new-vars
  36.           ,@(schemify-body (lambda-body node)
  37.                    (schemify-bind vars new-vars env)))))
  38.     ((letrec)
  39.      (let* ((vars (letrec-vars node))
  40.         (vals (letrec-vals node))
  41.         (new-vars (map (lambda (var) (externalize-variable var env))
  42.                    vars))
  43.         (env (schemify-bind vars new-vars env)))
  44.        `(letrec ,(map (lambda (var val)
  45.                 `(,var ,(schemify val env)))
  46.               new-vars
  47.               vals)
  48.             ,@(schemify-body (letrec-body node) env))))
  49.     ((if)
  50.      (let ((test (schemify (if-test node) env))
  51.            (con  (schemify (if-con node) env))
  52.            (alt  (schemify (if-alt node) env)))
  53.        ;;+++ Deal with an UNSPECIFIED alt
  54.        `(if ,test ,con ,alt)))
  55.     ((set!)
  56.      `(set! ,(schemify (set!-lhs node) env)
  57.         ,(schemify (set!-rhs node) env)))
  58.     ((begin)
  59.      `(begin ,(schemify (begin-first node) env)
  60.          ,@(unbeginify (schemify (begin-second node) env))))
  61.     ((define)
  62.      (let ((var (schemify (define-lhs node) env)))
  63.        (if (not (symbol? var))
  64.            (error "defining a non-variable -- shouldn't happen" var))
  65.        `(define ,var
  66.           ,(schemify (define-rhs node) env))))
  67.     (else
  68.      `(unknown-node-type ,node)))
  69.       node))
  70.  
  71. (define (schemify-call node env)
  72.   (let* ((proc (call-proc node))
  73.      (args (call-args node))
  74.      (punt (lambda ()
  75.          `(,(schemify proc env)
  76.            ,@(map (lambda (subnode) (schemify subnode env))
  77.               args)))))
  78.     (case (node-type proc)
  79.       ((lambda)
  80.        ;; +++ Check for mismatching # of args
  81.        (let ((proc-exp (schemify proc env)))
  82.      `(let ,(map (lambda (var arg) `(,var ,(schemify arg env)))
  83.              (cadr proc-exp)
  84.              args)
  85.         ,@(cddr proc-exp))))
  86.       ((program-variable)
  87.        ;; Rather kludgey.
  88.        (cond ((eq? (program-variable-cl-symbol proc)
  89.            (program-env-lookup revised^4-scheme-env 'and-aux))
  90.           `(and ,(schemify (car args) env)
  91.             ,(dethunkify (cadr args) env)))
  92.          ((eq? (program-variable-cl-symbol proc)
  93.            (program-env-lookup revised^4-scheme-env 'or-aux))
  94.           `(or ,(schemify (car args) env)
  95.            ,(dethunkify (cadr args) env)))
  96.          ((eq? (program-variable-cl-symbol proc)
  97.            (program-env-lookup revised^4-scheme-env 'case-aux))
  98.           `(case ,(schemify (car args) env)
  99.          ,@(map (lambda (keys arg)
  100.               `(,keys ,@(unbeginify (dethunkify arg env))))
  101.             (constant-value (cadr args))
  102.             (cdddr args))
  103.          (else ,(dethunkify (caddr args) env))))
  104.          ;; make-promise
  105.          (else (punt))))
  106.       (else (punt)))))
  107.  
  108. (define (dethunkify node env)
  109.   (if (and (lambda? node)
  110.        (null? (lambda-vars node)))
  111.       (schemify (lambda-body node) env)
  112.       `(,(schemify node env))))
  113.  
  114. (define (schemify-body node env)
  115.   (unbeginify (schemify node env)))
  116.  
  117. (define (unbeginify exp)
  118.   (if (car-is? exp 'begin) (cdr exp) (list exp)))
  119.  
  120. ; Generate a non-conflicting name
  121.  
  122. (define (externalize-variable var env)
  123.   (let ((name (local-variable-name var)))
  124.     (if (rassq name env)
  125.     (make-name-from-uid name (generate-uid))
  126.     name)))
  127.  
  128. (define (schemify-bind vars names env)
  129.   (append (map cons vars names) env))
  130.