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

Text File | 1990-02-20 | 16KB | 583 lines

; Expression classification

; Entry points (not a complete list):
;  classify
;  scan-body
;  process-syntax-binding   [for use by define-syntax]
;  classify-let-syntax, classify-letrec-syntax
;  bind
;  bindrec
;  bind-aliases
;  lookup
;  lookup-variable

;  classify : form * env * (class * form * env -> answer) -> answer
;  env = name -> binding
;  binding = special + macro + variable
;  special = {let-syntax, letrec-syntax, define, begin, ...}
;  variable = [defined elsewhere]
;  macro = transformer * env
;  transformer = form * (name -> name) * (name * name -> bool) -> form

(define (classify form env cont)
  (cond ((literal? form)
     (cont class/literal form env))
    ((name? form)
     (cont class/variable form env))
    ((compound? form)
     (classify-compound form env cont))
    ((classified? form)
     (cont (classified-class form)
           (classified-form form)
           (classified-env form)))
    (else (syntax-error "unknown expression type" form))))

(define (classify-compound form env cont)
  (let ((op-form (operator form)))
    (if (name? op-form)
    (let ((binding (lookup op-form env)))
      (cond ((special-operator? binding)
         (classify-special-form binding form env cont))
        ((macro? binding)
         (classify-macro-application binding form env cont))
        (else
         (cont class/application form env))))
    (cont class/application form env))))

(define (classify-special-form op form env cont)
  (let ((class (special-operator-class op)))
    (if (check-special-form-syntax class form)
    (cont class form env)
    (syntax-error "invalid special form syntax" form))))

; Macro application

(define (classify-macro-application op form env cont)
  (let ((macro-env (macro-environment op)))
    (with-new-color macro-env env
      (lambda (rename output-env)
    (let* ((compare (lambda (client-name macro-name)
              (same-binding? (lookup client-name env)
                     (lookup macro-name macro-env))))
           (new-form
        ((macro-transformer op) form rename compare)))
      (classify new-form output-env cont))))))

; let-syntax and letrec-syntax

(define (classify-let-syntax form env cont)
  (let ((bspecs (let-syntax-bspecs form)))
    (classify (let-syntax-body form)
    (bind (map bspec-name bspecs)
          (map (lambda (bspec)
             (process-syntax-binding (bspec-rhs bspec)
                         env))
           bspecs)
          env)
      cont)))

(define (classify-letrec-syntax form outer-env cont)
  (let ((bspecs (letrec-syntax-bspecs form)))
    (classify (letrec-syntax-body form)
    (bindrec (map bspec-name bspecs)
         (lambda (env)
           (map (lambda (bspec)
              (process-syntax-binding (bspec-rhs bspec)
                          env))
            bspecs))
         outer-env)
      cont)))

(define (process-syntax-binding transformer env)
  (make-macro (if (procedure? transformer)
          transformer
          (eval-transformer transformer
                    (get-transformer-environment env)))
          env))

(define (make-classified class form env)
  (vector 'classified class form env))
(define classified?
  (vector-predicate 'classified))
(define classified-class
  (vector-accessor 'classified 1))
(define classified-form
  (vector-accessor 'classified 2))
(define classified-env
  (vector-accessor 'classified 3))

; Process internal definitions

; This code goes to considerable contortions in order to avoid using
; side effects.  I think that it could be considerably simplified if
; it were less scrupulous about that.

; It could also be simplified if it were willing to expand the forms
; in the body more than once.

; There is still one bug: if a body contains more than one expression
; (following some number of definitions), and classifying the first of
; those expressions uses a name bound outside the body to a syntactic
; operator, and that name is shadowed by one of the definitions, then
; the wrong (outer) binding of that name will be used in classifying
; the body.  (Example: (lambda () (define cond list) (cond 1 2) 3).)
; This can be fixed, but I've already wasted too much time on this
; problem.

(define (scan-body forms env cont)
  (tracking-lookups env        ; Only for error checking
    (lambda (env seen-thunk)
      (let ((done
         (lambda (names def-forms body-forms)
           (let ((seen (seen-thunk)))
         (for-each (lambda (name)
                 (if (name-member name seen)
                 (syntax-error "defined name was used in expanding definition"
                           name)))
               names))
           (cont names def-forms body-forms))))
    (let loop ((names '())
           (def-forms '())
           (forms forms))
      (if (null? (cdr forms))  ;Optimization.
          ;; Last form must be an expression.
          (done names def-forms forms)
          (scan-body-form (car forms)
                  (re-extension-barrier env)
                  (lambda (more-names more-def-forms)
                (loop (append more-names names)
                      (append more-def-forms def-forms)
                      (cdr forms)))
                  (lambda (form)
                (done names
                      def-forms
                      (cons form (cdr forms)))))))))))

(define (scan-body-form form env d-cont e-cont)
  (classify form env
    (lambda (class form env)
      (cond ((= class class/define)
         (let ((extender (re-extender env)))
           (d-cont (list (define-name form))
               (list (lambda (env cont)
                   (classify (define-rhs form)
                   (extender env)
                 cont))))))
        ((= class class/begin)
         (scan-body-begin form env d-cont e-cont))
        (else
         (e-cont (make-classified class form env)))))))

(define (scan-body-begin form env d-cont e-cont)
  (let ((forms (begin-statements form)))
    (cond ((null? forms) (d-cont '() '()))
      ((null? (cdr forms))
       (scan-body-form (car forms) env d-cont e-cont))
      (else
       (scan-body-form
          (car forms)
          env
          (lambda (names def-forms)
        (let loop ((names names)
               (def-forms def-forms)
               (forms (cdr forms)))
          (if (null? forms)
              (d-cont names def-forms)
              (scan-body-form
                 (car forms)
             env
             (lambda (more-names more-def-forms)
               (loop (append more-names names)
                 (append more-def-forms def-forms)
                 (cdr forms)))
             (lambda (form)
               (syntax-error "intermixed expressions and definitions"
                     form))))))
          (lambda (form)
        (e-cont (make-classified class/begin
                     `(begin ,form ,@(cdr forms))
                     env))))))))

; Environment operations

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

(define (lookup-variable name env)
  (let ((binding (lookup name env)))
    (if (or (special-operator? binding)
        (macro? binding))
    (syntax-error "syntactic keyword encountered in invalid context" name)
    binding)))

(define (simple-environment lookup outer-env)
  (lambda (op)
    (case op
      ((lookup) lookup)
      (else (outer-env op)))))

(define (bind names bindings outer-env)
  (simple-environment
    (lambda (name)
      (lookup-internal name names bindings outer-env))
    outer-env))

(define (bindrec names bindings-proc outer-env)
  (letrec ((env (simple-environment
          (lambda (name)
            (lookup-internal name names (force bindings)
                     outer-env))
          outer-env))
       (bindings (delay (bindings-proc env))))
    env))

(define (lookup-internal name names bindings outer-env)
  (let loop ((names names) (bindings bindings))
    (if (null? names)
    (lookup name outer-env)
    (if (same-name? name (car names))
        (car bindings)
        (loop (cdr names) (cdr bindings))))))

; Keep track of keyword lookups for lambda body error checking.

(define (tracking-lookups env cont)
  (let ((seen '()))
    (cont (simple-environment
         (lambda (name)
           (let ((binding (lookup name env)))
         (if (or (macro? binding)
             (special-operator? binding))
             (set! seen (cons name seen)))
         binding))
         env)
      (lambda () seen))))

; Make a mutable environment, for program top level and/or REP loop.

(define (make-mutable-environment transformer-env)
  (let ((defined (make-table)))
    (let ((lookup
       (lambda (name)
         (or (table-ref defined name)
         (make-unbound name))))
      (define!
       (lambda (name binding)
         (table-set! defined name binding))))
      (lambda (op)
    (case op
      ((lookup) lookup)
      ((define!) define!)
      ((transformer-environment) transformer-env)
      (else (error "unknown environment operation" op)))))))

(define (environment-define! env name binding)
  ((env 'define!) name binding))

; Get the environment in which to evaluate transformer procedure expressions.

(define (get-transformer-environment env)
  (env 'transformer-environment))

; Environment for macro output

(define (diversion-environment color macro-env client-env)
  (simple-environment
    (lambda (name)
      (if (and (painted? name)
           (same-color? (painted-color name) color))
      (lookup (painted-name name) macro-env)
      (lookup name client-env)))
    client-env))

; Kludgiferous stuff for internal define

(define (re-extension-barrier env)
  (lambda (op)
    (case op
      ((re-extender) (lambda (env) env))
      (else (env op)))))

(define (re-extendable-environment extend outer-env)
  (let ((env (extend outer-env)))
    (lambda (op)
      (case op
    ((re-extender)
     ;; Kludge for processing internal defines
     (let ((outer-extend (re-extender outer-env)))
       (lambda (env-again)
         (outer-extend (extend env-again)))))
    (else (env op))))))

(define (re-extender env)
  (env 're-extender))

; Define special operator names to be special operators.

(define (define-special-operators! env)
  (for-each (lambda (name class)
          (environment-define! env name (make-special-operator class)))
        (list 'let-syntax 'letrec-syntax
          'define-syntax '%define
          'lambda 'letrec 'if
          'quote 'begin 'set!)
        (list class/let-syntax class/letrec-syntax
          class/define-syntax class/define
          class/lambda class/letrec class/if
          class/quote class/begin class/set!)))

; Binding = special operator + macro + unbound + variable
; All of these can be compared using EQ?, except unbound.

(define same-binding? equal?)

; Special operators

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

; Macros

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

; Unbound

(define (make-unbound name) (vector 'unbound name))
(define unbound? (vector-predicate 'unbound))
(define unbound-name (vector-accessor 'unbound 1))

; 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 (name? thing)
  (or (symbol? thing) (painted? thing)))

(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)
     (let ((new (make-vector (vector-length thing))))
       (let loop ((i 0) (same? #t))
         (if (>= i (vector-length thing))
         (if same? thing new)
         (let ((x (unpaint (vector-ref thing i))))
           (vector-set! new i x)
           (loop (+ i 1)
             (and same? (eq? x (vector-ref thing i)))))))))
    (else thing)))

(define (name->symbol name)
  (cond ((symbol? name) name)
    ((painted? name)
     (string->symbol
      (string-append "."
             (symbol->string (name->symbol (painted-name name)))
             "."
             (number->string (painted-color name) '(heur)))))
    (else (error "not a name" name))))

(define *color* 0)

(define (new-color)
  (set! *color* (+ *color* 1))
  *color*)

(define same-color? =)

(define (with-new-color macro-env client-env cont)
  (let ((alist '())            ;list of name * painted
    (color (new-color)))
    (cont (lambda (name)
        (let ((probe (assq name alist)))
          (if probe
          (cdr probe)
          (let ((new-name (make-painted name color)))
            (set! alist (cons (cons name new-name)
                      alist))
            new-name))))
      (re-extendable-environment
        (lambda (client-env)
          (diversion-environment color macro-env client-env))
        client-env))))

(define same-name? eq?)
(define name-member memq)
(define name-assoc assq)

; Expressions

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

(define (literal-value lit) lit)

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

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

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

(define (check-let-syntax exp)
  (and (= (careful-length exp) 3)
       (careful-every check-bspec (let-syntax-bspecs exp))))

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

(define letrec-syntax-bspecs let-syntax-bspecs)
(define letrec-syntax-body   let-syntax-body)

(define check-letrec-syntax check-let-syntax)

; Binding specs (<name> <exp>)

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

(define (check-bspec bspec)
  (and (= (careful-length bspec) 2)
       (name? (bspec-name bspec))))

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

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

(define (check-define form)
  (and (= (careful-length form) 3)
       (name? (define-name form))))

; (define-syntax <name> <rhs>)

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

(define (check-define-syntax form)
  (and (= (careful-length form) 3)
       (name? (define-syntax-name form))))

; (begin <statement>*)

(define begin-statements cdr)

(define (check-begin form)
  (>= (careful-length form) 1))  ;must be a proper list

; variable reference

(define (variable-name var) var)

; application

(define application-procedure operator)
(define application-arguments operands)

; (lambda (<name>*) <body>)

(define lambda-formals cadr)
(define lambda-body cddr)

(define (check-lambda exp)
  (and (>= (careful-length exp) 3)
       (let recur ((formals (lambda-formals exp)))
     (or (null? formals)
         (name? formals)
         (and (name? (car formals)) (recur (cdr formals)))))))

; (letrec ((<name> <exp>)) <body>)

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

(define (check-letrec exp)
  (and (>= (careful-length exp) 3)
       (careful-every check-bspec (letrec-bspecs exp))))

; (quote <text>)

(define quotation-text cadr)

(define (check-quote exp)
  (= (careful-length exp) 2))

; (if <test> <con> <alt>)

(define if-test cadr)
(define if-consequent caddr)
(define (if-alternate exp)
  (let ((z (cdddr exp)))
    (if (null? z) unspecified-expression (car z))))
(define unspecified-expression (list 'unspecified-value))

(define (check-if exp)
  (let ((len (careful-length exp)))
    (or (= len 3) (= len 4))))

; (set! <lhs> <rhs>)

(define set!-lhs cadr)
(define set!-rhs caddr)

(define (check-set! exp)
  (and (= (careful-length exp) 3)
       (name? (set!-lhs exp))))

;

(define (careful-length l)
  (if (null? l)
      0
      (if (pair? l)
      (+ 1 (careful-length (cdr l)))
      -1)))

(define (careful-every pred l)
  (if (null? l)
      #t
      (and (pair? l)
       (pred (car l))
       (careful-every pred (cdr l)))))

(define (check-special-form-syntax class form)
  ((vector-ref syntax-checkers class) form))

(define syntax-checkers
  (let ((v (make-vector number-of-classes (lambda (form) #t))))
    (vector-set! v class/lambda        check-lambda)
    (vector-set! v class/letrec        check-letrec)
    (vector-set! v class/if            check-if)
    (vector-set! v class/quote         check-quote)
    (vector-set! v class/begin         check-begin)
    (vector-set! v class/set!          check-set!)
    (vector-set! v class/let-syntax    check-let-syntax)
    (vector-set! v class/letrec-syntax check-letrec-syntax)
    (vector-set! v class/define        check-define)
    (vector-set! v class/define-syntax check-define-syntax)
    v))

; (put 'bind 'scheme-indent-hook nil)