dynamic.scm

Scheme跨平台编译器

; write-to-port

(define (write-to-port prog port)
  ; writes a program to a port
  (for-each
   (lambda (command)
     (pretty-print command port)
     (newline port))
   prog)
  '())

; write-file 

(define (write-to-file prog filename)
  ; write a program to a file
  (let ((port (open-output-file filename)))
    (write-to-port prog port)
    (close-output-port port)
    '()))

; ----------------------------------------------------------------------------
; Typed abstract syntax tree management: constraint generation, display, etc.
; ----------------------------------------------------------------------------


;; Abstract syntax operations, incl. constraint generation

(define (ast-gen syntax-op arg)
  ; generates all attributes and performs semantic side effects
  (let ((ntvar
         (case syntax-op
           ((0 29 31) (null2))
           ((1) (boolean))
           ((2) (character))
           ((3) (number))
           ((4) (charseq))
           ((5) (symbol))
           ((6) (let ((aux-tvar (gen-tvar)))
                  (for-each (lambda (t)
                              (add-constr! t aux-tvar))
                            (map ast-tvar arg))
                  (array aux-tvar)))
           ((7 30 32) (let ((t1 (ast-tvar (car arg)))
                            (t2 (ast-tvar (cdr arg))))
                        (pair t1 t2)))
           ((8) (gen-tvar))
           ((9) (ast-tvar arg))
           ((10) (let ((in-env (dynamic-lookup arg dynamic-top-level-env)))
                   (if in-env
                       (instantiate-type (binding-value in-env))
                       (let ((new-tvar (gen-tvar)))
                         (set! dynamic-top-level-env (extend-env-with-binding
                                              dynamic-top-level-env
                                              (gen-binding arg new-tvar)))
                         new-tvar))))
           ((11) (let ((new-tvar (gen-tvar)))
                   (add-constr! (procedure (ast-tvar (cdr arg)) new-tvar)
                                (ast-tvar (car arg)))
                   new-tvar))
           ((12) (procedure (ast-tvar (car arg))
                            (ast-tvar (tail (cdr arg)))))
           ((13) (let ((t-test (ast-tvar (car arg)))
                       (t-consequent (ast-tvar (cadr arg)))
                       (t-alternate (ast-tvar (cddr arg))))
                   (add-constr! (boolean) t-test)
                   (add-constr! t-consequent t-alternate)
                   t-consequent))
           ((14) (let ((var-tvar (ast-tvar (car arg)))
                       (exp-tvar (ast-tvar (cdr arg))))
                   (add-constr! var-tvar exp-tvar)
                   var-tvar))
           ((15) (let ((new-tvar (gen-tvar)))
                   (for-each (lambda (body)
                               (add-constr! (ast-tvar (tail body)) new-tvar))
                             (map cdr arg))
                   (for-each (lambda (e)
                               (add-constr! (boolean) (ast-tvar e)))
                             (map car arg))
                   new-tvar))
           ((16) (let* ((new-tvar (gen-tvar))
                        (t-key (ast-tvar (car arg)))
                        (case-clauses (cdr arg)))
                   (for-each (lambda (exprs)
                               (for-each (lambda (e)
                                           (add-constr! (ast-tvar e) t-key))
                                         exprs))
                             (map car case-clauses))
                   (for-each (lambda (body)
                               (add-constr! (ast-tvar (tail body)) new-tvar))
                             (map cdr case-clauses))
                   new-tvar))
           ((17 18) (for-each (lambda (e)
                                (add-constr! (boolean) (ast-tvar e)))
                              arg)
                    (boolean))
           ((19 21 22) (let ((var-def-tvars (map ast-tvar (caar arg)))
                             (def-expr-types (map ast-tvar (cdar arg)))
                             (body-type (ast-tvar (tail (cdr arg)))))
                         (for-each add-constr! var-def-tvars def-expr-types)
                         body-type))
           ((20) (let ((var-def-tvars (map ast-tvar (caadr arg)))
                       (def-expr-types (map ast-tvar (cdadr arg)))
                       (body-type (ast-tvar (tail (cddr arg))))
                       (named-var-type (ast-tvar (car arg))))
                   (for-each add-constr! var-def-tvars def-expr-types)
                   (add-constr! (procedure (convert-tvars var-def-tvars) body-type)
                                named-var-type)
                   body-type))
           ((23) (ast-tvar (tail arg)))
           ((24) (error 'ast-gen
                        "Do-expressions not handled! (Argument: ~s) arg"))
           ((25) (gen-tvar))
           ((26) (let ((t-var (ast-tvar (car arg)))
                       (t-exp (ast-tvar (cdr arg))))
                   (add-constr! t-var t-exp)
                   t-var))
           ((27) (let ((t-var (ast-tvar (car arg)))
                       (t-formals (ast-tvar (cadr arg)))
                       (t-body (ast-tvar (tail (cddr arg)))))
                   (add-constr! (procedure t-formals t-body) t-var)
                   t-var))
           ((28) (gen-tvar))
           (else (error 'ast-gen "Can't handle syntax operator: ~s" syntax-op)))))
    (cons syntax-op (cons ntvar arg))))

(define ast-con car)
;; extracts the ast-constructor from an abstract syntax tree

(define ast-arg cddr)
;; extracts the ast-argument from an abstract syntax tree

(define ast-tvar cadr)
;; extracts the tvar from an abstract syntax tree


;; tail

(define (tail l)
  ;; returns the tail of a nonempty list
  (if (null? (cdr l))
      (car l)
      (tail (cdr l))))

; convert-tvars

(define (convert-tvars tvar-list)
  ;; converts a list of tvars to a single tvar
  (cond
   ((null? tvar-list) (null2))
   ((pair? tvar-list) (pair (car tvar-list)
                            (convert-tvars (cdr tvar-list))))
   (else (error 'convert-tvars "Not a list of tvars: ~s" tvar-list))))


;; Pretty-printing abstract syntax trees

(define (tast-show ast)
  ;; converts abstract syntax tree to list representation (Scheme program)
  (let ((syntax-op (ast-con ast))
        (syntax-tvar (tvar-show (ast-tvar ast)))
        (syntax-arg (ast-arg ast)))
    (cons
     (case syntax-op
       ((0 1 2 3 4 8 10) syntax-arg)
       ((29 31) '())
       ((30 32) (cons (tast-show (car syntax-arg))
                      (tast-show (cdr syntax-arg))))
       ((5) (list 'quote syntax-arg))
       ((6) (list->vector (map tast-show syntax-arg)))
       ((7) (list 'cons (tast-show (car syntax-arg))
                  (tast-show (cdr syntax-arg))))
       ((9) (ast-arg syntax-arg))
       ((11) (cons (tast-show (car syntax-arg)) (tast-show (cdr syntax-arg))))
       ((12) (cons 'lambda (cons (tast-show (car syntax-arg))
                                 (map tast-show (cdr syntax-arg)))))
       ((13) (cons 'if (cons (tast-show (car syntax-arg))
                             (cons (tast-show (cadr syntax-arg))
                                   (let ((alt (cddr syntax-arg)))
                                     (if (eqv? (ast-con alt) empty)
                                         '()
                                         (list (tast-show alt))))))))
       ((14) (list 'set! (tast-show (car syntax-arg))
                   (tast-show (cdr syntax-arg))))
       ((15) (cons 'cond
                   (map (lambda (cc)
                          (let ((guard (car cc))
                                (body (cdr cc)))
                            (cons
                             (if (eqv? (ast-con guard) empty)
                                 'else
                                 (tast-show guard))
                             (map tast-show body))))
                        syntax-arg)))
       ((16) (cons 'case
                   (cons (tast-show (car syntax-arg))
                         (map (lambda (cc)
                                (let ((data (car cc)))
                                  (if (and (pair? data)
                                           (eqv? (ast-con (car data)) empty))
                                      (cons 'else
                                            (map tast-show (cdr cc)))
                                      (cons (map datum-show data)
                                            (map tast-show (cdr cc))))))
                              (cdr syntax-arg)))))
       ((17) (cons 'and (map tast-show syntax-arg)))
       ((18) (cons 'or (map tast-show syntax-arg)))
       ((19) (cons 'let
                   (cons (map
                          (lambda (vd e)
                            (list (tast-show vd) (tast-show e)))
                          (caar syntax-arg)
                          (cdar syntax-arg))
                         (map tast-show (cdr syntax-arg)))))
       ((20) (cons 'let
                   (cons (tast-show (car syntax-arg))
                         (cons (map
                                (lambda (vd e)
                                  (list (tast-show vd) (tast-show e)))
                                (caadr syntax-arg)
                                (cdadr syntax-arg))
                               (map tast-show (cddr syntax-arg))))))
       ((21) (cons 'let*
                   (cons (map
                          (lambda (vd e)
                            (list (tast-show vd) (tast-show e)))
                          (caar syntax-arg)
                          (cdar syntax-arg))
                         (map tast-show (cdr syntax-arg)))))
       ((22) (cons 'letrec
                   (cons (map
                          (lambda (vd e)
                            (list (tast-show vd) (tast-show e)))
                          (caar syntax-arg)
                          (cdar syntax-arg))
                         (map tast-show (cdr syntax-arg)))))
       ((23) (cons 'begin
                   (map tast-show syntax-arg)))
       ((24) (error 'tast-show "Do expressions not handled! (~s)" syntax-arg))
       ((25) (error 'tast-show "This can't happen: empty encountered!"))
       ((26) (list 'define
                   (tast-show (car syntax-arg))
                   (tast-show (cdr syntax-arg))))
       ((27) (cons 'define
                   (cons
                    (cons (tast-show (car syntax-arg))
                          (tast-show (cadr syntax-arg)))
                    (map tast-show (cddr syntax-arg)))))
       ((28) (cons 'begin
                   (map tast-show syntax-arg)))
       (else (error 'tast-show "Unknown abstract syntax operator: ~s"
                    syntax-op)))
     syntax-tvar)))

;; tast*-show

(define (tast*-show p)
  ;; shows a list of abstract syntax trees
  (map tast-show p))


;; counters for tagging/untagging

(define untag-counter 0)
(define no-untag-counter 0)
(define tag-counter 0)
(define no-tag-counter 0)
(define may-untag-counter 0)
(define no-may-untag-counter 0)

(define (reset-counters!)
  (set! untag-counter 0)
  (set! no-untag-counter 0)
  (set! tag-counter 0)
  (set! no-tag-counter 0)
  (set! may-untag-counter 0)
  (set! no-may-untag-counter 0))

(define (counters-show)
  (list
   (cons tag-counter no-tag-counter)
   (cons untag-counter no-untag-counter)
   (cons may-untag-counter no-may-untag-counter)))  


;; tag-show

(define (tag-show tvar-rep prog)
  ; display prog with tagging operation
  (if (eqv? tvar-rep dynamic)
      (begin
        (set! tag-counter (+ tag-counter 1))
        (list 'tag prog))
      (begin
        (set! no-tag-counter (+ no-tag-counter 1))
        (list 'no-tag prog))))


;; untag-show

(define (untag-show tvar-rep prog)
  ; display prog with untagging operation
  (if (eqv? tvar-rep dynamic)
      (begin
        (set! untag-counter (+ untag-counter 1))
        (list 'untag prog))
      (begin
        (set! no-untag-counter (+ no-untag-counter 1))
        (list 'no-untag prog))))

(define (may-untag-show tvar-rep prog)
  ; display possible untagging in actual arguments
  (if (eqv? tvar-rep dynamic)
      (begin
        (set! may-untag-counter (+ may-untag-counter 1))
        (list 'may-untag prog))
      (begin
        (set! no-may-untag-counter (+ no-may-untag-counter 1))
        (list 'no-may-untag prog))))


;; tag-ast-show

(define (tag-ast-show ast)
  ;; converts typed and normalized abstract syntax tree to
  ;; a Scheme program with explicit tagging and untagging operations
  (let ((syntax-op (ast-con ast))
        (syntax-tvar (find! (ast-tvar ast)))
        (syntax-arg (ast-arg ast)))
    (case syntax-op
      ((0 1 2 3 4)
       (tag-show syntax-tvar syntax-arg))
      ((8 10) syntax-arg)
      ((29 31) '())
      ((30) (cons (tag-ast-show (car syntax-arg))
                  (tag-ast-show (cdr syntax-arg))))
      ((32) (cons (may-untag-show (find! (ast-tvar (car syntax-arg)))
                              (tag-ast-show (car syntax-arg)))
                  (tag-ast-show (cdr syntax-arg))))
      ((5) (tag-show syntax-tvar (list 'quote syntax-arg)))
      ((6) (tag-show syntax-tvar (list->vector (map tag-ast-show syntax-arg))))
      ((7) (tag-show syntax-tvar (list 'cons (tag-ast-show (car syntax-arg))
                                       (tag-ast-show (cdr syntax-arg)))))
      ((9) (ast-arg syntax-arg))
      ((11) (let ((proc-tvar (find! (ast-tvar (car syntax-arg)))))
              (cons (untag-show proc-tvar 
                                (tag-ast-show (car syntax-arg)))
                    (tag-ast-show (cdr syntax-arg)))))
      ((12) (tag-show syntax-tvar
                      (cons 'lambda (cons (tag-ast-show (car syntax-arg))
                                          (map tag-ast-show (cdr syntax-arg))))))
      ((13) (let ((test-tvar (find! (ast-tvar (car syntax-arg)))))
              (cons 'if (cons (untag-show test-tvar
                                          (tag-ast-show (car syntax-arg)))
                              (cons (tag-ast-show (cadr syntax-arg))
                                    (let ((alt (cddr syntax-arg)))
                                      (if (eqv? (ast-con alt) empty)
                                          '()
                                          (list (tag-ast-show alt)))))))))
      ((14) (list 'set! (tag-ast-show (car syntax-arg))
                  (tag-ast-show (cdr syntax-arg))))
      ((15) (cons 'cond
                  (map (lambda (cc)
                         (let ((guard (car cc))
                               (body (cdr cc)))
                           (cons
                            (if (eqv? (ast-con guard) empty)
                                'else
                                (untag-show (find! (ast-tvar guard))
                                            (tag-ast-show guard)))
                            (map tag-ast-show body))))
                       syntax-arg)))
      ((16) (cons 'case
                  (cons (tag-ast-show (car syntax-arg))
                        (map (lambda (cc)
                               (let ((data (car cc)))
                                 (if (and (pair? data)