The World of Computer Software/World_Of_Computer_Software-02-386-Vol-2of3.iso/c/cr-macro.zip/INTERP.SCM

Text File | 1990-02-09 | 11KB | 412 lines

; Abstract interpreter for macro proposal

;  interpret : exp * env -> result
;
;  syntax = special + macro
;  special = {'macro, 'let, 'letrec, 'define, 'begin, 'lambda, 'if, 'set!, 'quote}
;  macro = transformer * env
;  definitions = (name * result)*
;  value = boolean + number + pair + procedure + ...
;
;  env = name -> binding
;  binding = syntax + variable

(define (interpret exp env model)
  (cond ((literal? exp)
     ((model 'literal) exp env model))
    ((name? exp)
     (interpret-name exp env model))
    ((compound? exp)
     (interpret-compound exp env model))
    (else (error "unknown expression type" exp))))

(define (interpret-compound exp env model)
  (let ((op (interpret (operator exp) env model)))
    (cond ((special-operator? op)
       (interpret-special-form op exp env model))
      ((macro-result? op)
       (interpret-macro-application op exp env model))
      (else
       (interpret-combination op exp env model)))))

(define (interpret-special-form op exp env model)
  (let ((type (special-operator-type op)))
    (case type
      ((macro)         (interpret-macro         exp env model))
      ((let-syntax)    (interpret-let-syntax    exp env model))
      ((letrec-syntax) (interpret-letrec-syntax exp env model))
      (else (model type exp env)))))

(define (interpret-name exp env model)
  (let ((binding (lookup exp env)))
    (cond ((syntax-result? binding) binding)
      (else (model 'variable binding env)))))

; Macro application

(define (interpret-macro exp env model)
  (let ((transformer (macro-transformer exp)))
    (make-macro-result (if (procedure? transformer)
               transformer
               (eval-transformer transformer))
               env)))

(define (interpret-macro-application op exp env model)
  (with-new-color
    (lambda (rename alist-promise)
      (let* ((macro-env (macro-result-environment op))
         (compare (lambda (client-name macro-name)
            (same-binding? (lookup client-name env)
                       (lookup macro-name macro-env))))
         (new-exp ((macro-result-transformer op) exp rename same-binding?)))
    (model 'macro-application
           (make-macro-application
           new-exp
           (force alist-promise)
           macro-env)        ;???
           env)))))

; let-syntax and letrec-syntax

(define (interpret-let-syntax exp env model)
  (interpret-body (let-syntax-body exp)
          (bind ... env)
          model))

(define (interpret-letrec-syntax exp outer-env)
  (interpret-body (letrec-syntax-body exp)
          (bind ... env)
          model))

; Process internal definitions

(define (with-body-environment env cont)
  (let* ((seen '())
     (env (lambda (request name)
        (if (eq? request 'lookup)
            (set! seen (cons name seen)))
        (env request name))))
    (cont env (lambda () seen))))

(define (interpret-body forms env model)
  (with-body-environment env
    (lambda (env seen-thunk)
      (let ((done (lambda (ds forms seen)
            (let ((names (map definition-name ds)))
              (for-each (lambda (name)
                  (if (memq name seen)
                      (error "defined name was used in expanding definition"
                         name)))
                names)
              (model 'body
                 (make-body names (map definition-rhs-proc ds) forms)
                 env)))))
    (let loop ((forms forms)
           (ds '())
           (seen '()))
      (if (null? (cdr forms))
          ;; Body must contain at least one statement
          (done ds forms seen)
          (let ((first (interpret (car forms) env body-model)))
        (if (eq? first 'expression)
            (done ds forms seen)
            (loop (cdr forms)
              (append first ds)
              (seen-thunk))))))))))

(define (body-model operator exp env)
  (case operator
    ((define)
     (make-definitions
      (list (make-definition (define-name exp)
                 (lambda (env model)
                   (interpret (define-rhs exp) env model))))))
    ((begin)
     (let ((forms (begin-statements exp)))
       (cond ((null? forms) ds)
         ((null? (cdr forms)) (interpret (car forms) env body-model))
         (else (let ((first (interpret (car forms) env)))
             (if (eq? first 'expression)
             'expression
             (apply append
                (cons first
                      (map (lambda (form)
                         (let ((ds (interpret form env body-model)))
                           (if (eq? ds 'expression)
                           (error "intermixed expressions and definitions"
                              exp)
                           ds)))
                       (cdr forms))))))))))
    ((macro-application)
     (let ((result (interpret new-exp (rename alist macro-env env) body-model)))
       (if (definitions? result)
       (make-definitions (map (lambda (d)
                    (make-definition (definition-name d)
                             (lambda (env model)
                               (interpret-definition-rhs d
                                         (rename alist macro-env env)
                                         model))))
                  (definitions-list result)))
       'expression)))
    (else 'expression)))

; Environment operations

(define (lookup name env)
  (env 'lookup name))

(define (obtain-bindings ds)    ; returns list of (name . binding)
  (let ((names (map definition-name ds)))
    (map cons
     names
     (make-bindings names
            (map force-definition-rhs ds)))))

; Bind takes list of definitions (name . result-promise)

(define (bind ds env)
  (really-bind (lambda () ds)
           (delay (obtain-bindings ds))
           env))

(define (really-bind current-ds alist-promise env)
  (lambda (name)
    (if (assq name (current-ds))
    (cdr (assq name (force alist-promise)))
    (lookup name env))))

; For internal definitions: it must be possible to expand all of the
; definitions without knowing the binding of any of them.  The
; bookkeeping is a pain.

(define (make-body-environment outer-env cont)
  (let ((ds '())
    (seen '())
    (more? #t))
    (letrec ((env (really-bind (lambda () ds)
                   (delay (begin (set! more? #f)
                         (obtain-bindings ds)))
                   outer-env)))
      (cont (lambda (name)
          (if more? (set! seen (cons name seen)))
          (lookup name env))
        (lambda (new-ds)
          (if more?
          (if (any (lambda (name)
                 (assq name new-ds))
               seen)
              (error "invalid forward definition reference" ds)
              (set! ds (merge-alists new-ds ds)))
          (error "definition occurs too late" ds)))))))

; This is used by macro application.
; Compare with filter-syntactic-environment and extend-syntactic-environment
; in Bawden's implementation.

(define (rename name+new-list new-env else-env)
  (lambda (name)
    (let ((probe (right-assq name name+new-list)))
      (if probe
      (lookup (car probe) new-env)
      (lookup name else-env)))))

(define same-binding? equal?)

; Syntax

(define (syntax-result? result)
  (or (special-operator? result)
      (macro-result? result)))

; Special operators

(define (make-special-operator type)
  (vector 'special type))
(define special-operator?
  (vector-predicate 'special))
(define special-operator-type
  (vector-accessor 'special 1))

(define (bind-special-operators env)
  (bind (map (lambda (name)
           (make-definition name (delay (make-special-operator name))))
         '(macro let letrec define begin lambda quote if set!))
    env))

; Macros

(define (make-macro-result transformer env)
  (vector 'macro transformer env))
(define macro-result?
  (vector-predicate 'macro))
(define macro-result-transformer
  (vector-accessor 'macro 1))
(define macro-result-environment
  (vector-accessor 'macro 2))

; Names, colors, painting

(define (make-painted name color)
  (vector 'painted name color))
(define painted? (vector-predicate 'painted))
(define painted-name (vector-accessor 'painted 1))
(define painted-color (vector-accessor 'painted 2))

(define (unpaint thing)
  (cond ((painted? thing) (unpaint (painted-name thing)))
    ((pair? thing)
     (let ((x (unpaint (car thing)))
           (y (unpaint (cdr thing))))
       (if (and (eq? x (car thing))
            (eq? y (cdr thing)))
           thing
           (cons x y))))
    ((vector? thing) ...)
    (else thing)))

(define (name? thing)
  (or (symbol? thing) (painted? thing)))

(define (name->symbol name)
  (if (symbol? name)
      name
      (string->symbol (string-append "."
                     (number->string (painted-color name) '(heur))
                     "."
                     (symbol->string (name->symbol (painted-name name)))))))

(define *counter* 0)

(define (make-name-generator)
  ;; Don't bump counter if no names are generated
  (let ((color (delay (begin (set! *counter* (+ *counter* 1))
                 *counter*))))
    (lambda (name)
      (make-painted name (force color)))))

(define (with-new-color cont)
  (let ((alist '())            ;list of name * painted
    (more? #t)
    (gen (make-name-generator)))
    (cont (lambda (name)
        (let ((probe (assq name alist)))
          (if probe
          (cdr probe)
          (if more?
              (let ((new-name (gen name)))
            (set! alist (cons (cons name new-name)
                      alist))
            new-name)
              (error "this color has expired" name)))))
      (delay (begin (set! more? #f)
            alist)))))

; Expressions

(define (literal? x)
  (or (number? x) (string? x) (boolean? x) (char? x)))

(define compound? pair?)
(define operator car)
(define operands cdr)

; (macro <transformer>)

(define macro-transformer cadr)

; (let-syntax ((<name> <exp>)) <body>)
; (letrec-syntax ((<name> <exp>)) <body>)

(define let-syntax-bspecs cadr)
(define let-syntax-body cddr)

(define letrec-syntax-bspecs cadr)
(define letrec-syntax-body cddr)

(define bspec-name car)
(define bspec-rhs cadr)

; (define <name> <rhs>)     [rhs = right-hand side]

(define define-name cadr)
(define define-rhs caddr)

; (begin <statement>*)

(define begin-statements cdr)

; Test routine

(define (run exp . maybe-env)
  (set! *counter* 0)
  (result->output
   (interpret exp (if (null? maybe-env)
              (top-env)
              (car maybe-env)))))

(define (top-env)
  (bind-special-operators
   (bind-primitive-values empty-environment)))

(define (defs->env defs . maybe-env)
  (make-body-environment (if (null? maybe-env)
                 (top-env)
                 (car maybe-env))
    (lambda (env define!)
      (let ((res (interpret `(begin ,@defs) env)))  ;kludge
    (if (definitions? res)
        (let ((ds (definitions-list res)))
          (define! ds)
          (for-each force-definition-rhs ds)
          env))))))


; Test cases

#||

(run '((macro (lambda (exp c) 1))))

(run '((macro (lambda (exp c) '+))))

(run '((macro (lambda (exp c) (c '+)))))

(run '((lambda () 2 1)))

(run '(begin (define x 1) (define y 2)))

(run '((lambda () (define x 1) x)))

(run '(let ((x 'outer))
    (let ((m (macro (lambda (exp paint) 'x))))
      (let ((x 'inner))
        (m)))))

(run '(let ((x 'outer))
    (let ((m (macro (lambda (exp paint) (paint 'x)))))
      (let ((x 'inner))
        (m)))))

(run '(letrec ((x (lambda () x)))
    (let ((y x))
      (set! x 2)
      (y))))

(run '(let ((x 'outer))
      (letrec ((m (macro (lambda (exp paint) (paint 'x))))
           (x 'inner))
          (m))))

(run '(let ((foo (lambda (x) (+ x 1))))
    (let ((m (macro (lambda (exp paint)
              `(,(paint 'foo) ,(cadr exp))))))
      (list (m 3)            ; => 4
        (let ((foo 97))
          (m foo)        ; => 98
          )))))

||#

; (put 'make-body-environment 'scheme-indent-hook 1)
; (put 'bind 'scheme-indent-hook nil)