home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / util / copy.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  3.0 KB  |  100 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; This copies ast structure
  3.  
  4. (define-walker copy ast-td-copy-ast-walker)
  5.  
  6. (define (copy-ast ast)
  7.   (copy-ast-1 ast '()))
  8.  
  9. (define (copy-ast-1 ast env)
  10.   (call-walker copy ast env))
  11.  
  12. (define (copy-ast/list l env)
  13.   (if (null? l)
  14.       l
  15.       (cons (copy-ast-1 (car l) env)
  16.         (copy-ast/list (cdr l) env))))
  17.  
  18. ;;; Walkers for special structs
  19.  
  20. ;;; assume env already has lhs definitions in it
  21. (define-walker-method copy valdef (object env)
  22.     (make valdef
  23.       (lhs (copy-ast-1 (valdef-lhs object) env))
  24.       (definitions (copy-ast/list (valdef-definitions object) env))
  25.       (module *module-name*)))
  26.  
  27. (define-walker-method copy single-fun-def (object env)
  28.   (with-slots single-fun-def (args rhs-list where-decls infix?) object
  29.     (let* ((env1 (add-local-patterns/copy args env))
  30.        (env2 (add-local-decls/copy where-decls env1)))
  31.       (make single-fun-def
  32.      (args (copy-ast/list args env2))
  33.      (rhs-list (copy-ast/list rhs-list env2))
  34.      (where-decls (copy-ast/list where-decls env2))
  35.      (infix? infix?)))))
  36.  
  37. (define-walker-method copy var-ref (object env)
  38.   (with-slots var-ref (name var infix?) object
  39.      (make var-ref
  40.     (name name)
  41.     (var (rename-var/copy var env))
  42.     (infix? infix?))))
  43.  
  44. (define-walker-method copy lambda (object env)
  45.   (let ((env1 (add-local-patterns/copy (lambda-pats object) env)))
  46.     (make lambda (pats (copy-ast/list (lambda-pats object) env1))
  47.              (body (copy-ast-1 (lambda-body object) env1)))))
  48.  
  49. (define-walker-method copy let (object env)
  50.   (let ((env1 (add-local-decls/copy (let-decls object) env)))
  51.     (make let (decls (copy-ast/list (let-decls object) env1))
  52.           (body (copy-ast-1 (let-body object) env1)))))
  53.  
  54. (define-walker-method copy alt (object env)
  55.   (with-slots alt (pat rhs-list where-decls) object
  56.     (let* ((env1 (add-local-pattern/copy pat env))
  57.        (env2 (add-local-decls/copy where-decls env1)))
  58.     (make alt (where-decls (copy-ast/list where-decls env2))
  59.           (rhs-list (copy-ast/list rhs-list env2))
  60.           (pat (copy-ast-1 pat env2))))))
  61.  
  62. (define-copy-walker-methods 
  63.   (guarded-rhs as-pat irr-pat var-pat wildcard-pat (const-pat match-fn)
  64.    (plus-pat match-fn bind-fn) pcon list-pat dynamic-pat if case
  65.    exp-sign app con-ref integer-const float-const char-const
  66.    string-const list-exp sequence sequence-to sequence-then
  67.    sequence-then-to omitted-guard))
  68.  
  69. ;;; %%% List comprehension stuff not done.
  70.  
  71. ;;; Environment stuff
  72.  
  73. (define (add-local-decls/copy decls env)
  74.   (dolist (d decls)
  75.     (when (valdef? d)
  76.       (setf env (add-local-pattern/copy (valdef-lhs d) env))))
  77.   env)
  78.  
  79. (define (add-local-patterns/copy ps env)
  80.   (if (null? ps)
  81.       env
  82.       (add-local-patterns/copy (cdr ps)
  83.                    (add-local-pattern/copy (car ps) env))))
  84.  
  85. (define (add-local-pattern/copy p env)
  86.   (add-bind/copy (collect-pattern-vars p) env))
  87.  
  88. (define (add-bind/copy vars env)
  89.   (if (null? vars)
  90.       env
  91.       (add-bind/copy
  92.        (cdr vars)
  93.        (cons (tuple (var-ref-var (car vars))
  94.             (create-local-definition (var-ref-name (car vars))))
  95.          env))))
  96.  
  97. (define (rename-var/copy var env)
  98.   (let ((new (assq var env)))
  99.     (if new (tuple-2-2 new) var)))
  100.