dynamic.scm

Scheme跨平台编译器

; Needed packages: type management

;(load "typ-mgmt.so")

(define (normalize-global-constraints!) 
  (normalize! global-constraints)
  (init-global-constraints!))

(define (normalize! constraints)
  (map (lambda (c)
         (equiv! (constr-lhs c) (constr-rhs c))) constraints))
; ----------------------------------------------------------------------------
; Abstract syntax definition and parse actions
; ----------------------------------------------------------------------------

; Needed packages: ast-gen.ss
;(load "ast-gen.ss")

;; Abstract syntax
;;
;; VarDef
;;
;; Identifier =         Symbol - SyntacticKeywords
;; SyntacticKeywords =  { ... } (see Section 7.1, IEEE Scheme Standard)
;;
;; Datum
;;
;; null-const:          Null            -> Datum
;; boolean-const:       Bool            -> Datum
;; char-const:          Char            -> Datum
;; number-const:        Number          -> Datum
;; string-const:        String          -> Datum
;; vector-const:        Datum*          -> Datum
;; pair-const:          Datum x Datum   -> Datum
;;
;; Expr
;;
;; Datum <              Expr
;;
;; var-def:             Identifier              -> VarDef
;; variable:            VarDef                  -> Expr
;; identifier:          Identifier              -> Expr
;; procedure-call:      Expr x Expr*            -> Expr
;; lambda-expression:   Formals x Body          -> Expr
;; conditional:         Expr x Expr x Expr      -> Expr
;; assignment:          Variable x Expr         -> Expr
;; cond-expression:     CondClause+             -> Expr
;; case-expression:     Expr x CaseClause*      -> Expr
;; and-expression:      Expr*                   -> Expr
;; or-expression:       Expr*                   -> Expr
;; let-expression:      (VarDef* x Expr*) x Body -> Expr
;; named-let-expression: VarDef x (VarDef* x Expr*) x Body -> Expr
;; let*-expression:     (VarDef* x Expr*) x Body -> Expr
;; letrec-expression:   (VarDef* x Expr*) x Body -> Expr
;; begin-expression:    Expr+                   -> Expr
;; do-expression:       IterDef* x CondClause x Expr* -> Expr
;; empty:                                       -> Expr
;;
;; VarDef* <            Formals
;;
;; simple-formal:       VarDef                  -> Formals
;; dotted-formals:      VarDef* x VarDef        -> Formals
;;
;; Body =               Definition* x Expr+     (reversed)
;; CondClause =         Expr x Expr+
;; CaseClause =         Datum* x Expr+
;; IterDef =            VarDef x Expr x Expr
;;
;; Definition
;;
;; definition:          Identifier x Expr       -> Definition
;; function-definition: Identifier x Formals x Body -> Definition
;; begin-command:       Definition*             -> Definition
;;
;; Expr <               Command
;; Definition <         Command
;;
;; Program =            Command*


;; Abstract syntax operators

; Datum

(define null-const 0)
(define boolean-const 1)
(define char-const 2)
(define number-const 3)
(define string-const 4)
(define symbol-const 5)
(define vector-const 6)
(define pair-const 7)

; Bindings

(define var-def 8)
(define null-def 29)
(define pair-def 30)

; Expr

(define variable 9)
(define identifier 10)
(define procedure-call 11)
(define lambda-expression 12)
(define conditional 13)
(define assignment 14)
(define cond-expression 15)
(define case-expression 16)
(define and-expression 17)
(define or-expression 18)
(define let-expression 19)
(define named-let-expression 20)
(define let*-expression 21)
(define letrec-expression 22)
(define begin-expression 23)
(define do-expression 24)
(define empty 25)
(define null-arg 31)
(define pair-arg 32)

; Command

(define definition 26)
(define function-definition 27)
(define begin-command 28)


;; Parse actions for abstract syntax construction

(define (dynamic-parse-action-null-const)
  ;; dynamic-parse-action for '()
  (ast-gen null-const '()))

(define (dynamic-parse-action-boolean-const e)
  ;; dynamic-parse-action for #f and #t
  (ast-gen boolean-const e))

(define (dynamic-parse-action-char-const e)
  ;; dynamic-parse-action for character constants
  (ast-gen char-const e))

(define (dynamic-parse-action-number-const e)
  ;; dynamic-parse-action for number constants
  (ast-gen number-const e))

(define (dynamic-parse-action-string-const e)
  ;; dynamic-parse-action for string literals
  (ast-gen string-const e))

(define (dynamic-parse-action-symbol-const e)
  ;; dynamic-parse-action for symbol constants
  (ast-gen symbol-const e))

(define (dynamic-parse-action-vector-const e)
  ;; dynamic-parse-action for vector literals
  (ast-gen vector-const e))

(define (dynamic-parse-action-pair-const e1 e2)
  ;; dynamic-parse-action for pairs
  (ast-gen pair-const (cons e1 e2)))

(define (dynamic-parse-action-var-def e)
  ;; dynamic-parse-action for defining occurrences of variables;
  ;; e is a symbol
  (ast-gen var-def e))

(define (dynamic-parse-action-null-formal)
  ;; dynamic-parse-action for null-list of formals
  (ast-gen null-def '()))

(define (dynamic-parse-action-pair-formal d1 d2)
  ;; dynamic-parse-action for non-null list of formals;
  ;; d1 is the result of parsing the first formal,
  ;; d2 the result of parsing the remaining formals
  (ast-gen pair-def (cons d1 d2)))

(define (dynamic-parse-action-variable e)
  ;; dynamic-parse-action for applied occurrences of variables
  ;; ***Note***: e is the result of a dynamic-parse-action on the
  ;; corresponding variable definition!
  (ast-gen variable e))

(define (dynamic-parse-action-identifier e)
  ;; dynamic-parse-action for undeclared identifiers (free variable
  ;; occurrences)
  ;; ***Note***: e is a symbol (legal identifier)
  (ast-gen identifier e))
 
(define (dynamic-parse-action-null-arg)
  ;; dynamic-parse-action for a null list of arguments in a procedure call
  (ast-gen null-arg '()))

(define (dynamic-parse-action-pair-arg a1 a2)
  ;; dynamic-parse-action for a non-null list of arguments in a procedure call
  ;; a1 is the result of parsing the first argument, 
  ;; a2 the result of parsing the remaining arguments
  (ast-gen pair-arg (cons a1 a2)))

(define (dynamic-parse-action-procedure-call op args)
  ;; dynamic-parse-action for procedure calls: op function, args list of arguments
  (ast-gen procedure-call (cons op args)))

(define (dynamic-parse-action-lambda-expression formals body)
  ;; dynamic-parse-action for lambda-abstractions
  (ast-gen lambda-expression (cons formals body)))

(define (dynamic-parse-action-conditional test then-branch else-branch)
  ;; dynamic-parse-action for conditionals (if-then-else expressions)
  (ast-gen conditional (cons test (cons then-branch else-branch))))

(define (dynamic-parse-action-empty)
  ;; dynamic-parse-action for missing or empty field
  (ast-gen empty '()))

(define (dynamic-parse-action-assignment lhs rhs)
  ;; dynamic-parse-action for assignment
  (ast-gen assignment (cons lhs rhs)))

(define (dynamic-parse-action-begin-expression body)
  ;; dynamic-parse-action for begin-expression
  (ast-gen begin-expression body))

(define (dynamic-parse-action-cond-expression clauses)
  ;; dynamic-parse-action for cond-expressions
  (ast-gen cond-expression clauses))

(define (dynamic-parse-action-and-expression args)
  ;; dynamic-parse-action for and-expressions
  (ast-gen and-expression args))

(define (dynamic-parse-action-or-expression args)
  ;; dynamic-parse-action for or-expressions
  (ast-gen or-expression args))

(define (dynamic-parse-action-case-expression key clauses)
  ;; dynamic-parse-action for case-expressions
  (ast-gen case-expression (cons key clauses)))

(define (dynamic-parse-action-let-expression bindings body)
  ;; dynamic-parse-action for let-expressions
  (ast-gen let-expression (cons bindings body)))

(define (dynamic-parse-action-named-let-expression variable bindings body)
  ;; dynamic-parse-action for named-let expressions
  (ast-gen named-let-expression (cons variable (cons bindings body))))

(define (dynamic-parse-action-let*-expression bindings body)
  ;; dynamic-parse-action for let-expressions
  (ast-gen let*-expression (cons bindings body)))

(define (dynamic-parse-action-letrec-expression bindings body)
  ;; dynamic-parse-action for let-expressions
  (ast-gen letrec-expression (cons bindings body)))

(define (dynamic-parse-action-definition variable expr)
  ;; dynamic-parse-action for simple definitions
  (ast-gen definition (cons variable expr)))

(define (dynamic-parse-action-function-definition variable formals body)
  ;; dynamic-parse-action for function definitions
  (ast-gen function-definition (cons variable (cons formals body))))


(define dynamic-parse-action-commands (lambda (a b) (cons a b)))
;; dynamic-parse-action for processing a command result followed by a the
;; result of processing the remaining commands


;; Pretty-printing abstract syntax trees

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


;; ast*-show

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


;; datum-show

(define (datum-show ast)
  ;; prints an abstract syntax tree as a datum
  (case (ast-con ast)
    ((0 1 2 3 4 5) (ast-arg ast))
    ((6) (list->vector (map datum-show (ast-arg ast))))
    ((7) (cons (datum-show (car (ast-arg ast))) (datum-show (cdr (ast-arg ast)))))
    (else (error 'datum-show "This should not happen!"))))