dynamic.scm

Scheme跨平台编译器

; dynamic-parse-begin

(define (dynamic-parse-begin env args)
  (dynamic-parse-action-begin-expression
   (dynamic-parse-body env args)))


; dynamic-parse-cond

(define (dynamic-parse-cond env args)
  (if (and (pair? args) (list? args))
      (dynamic-parse-action-cond-expression
       (map (lambda (e)
              (dynamic-parse-cond-clause env e))
            args))
      (error 'dynamic-parse-cond "Not a list of cond-clauses: ~s" args)))

; dynamic-parse-cond-clause

(define (dynamic-parse-cond-clause env e)
  ;; ***Note***: Only (<test> <sequence>) is permitted!
  (if (pair? e)
      (cons
       (if (eqv? (car e) 'else)
           (dynamic-parse-action-empty)
           (dynamic-parse-expression env (car e)))
       (dynamic-parse-body env (cdr e)))
      (error 'dynamic-parse-cond-clause "Not a cond-clause: ~s" e)))


; dynamic-parse-and

(define (dynamic-parse-and env args)
  (if (list? args)
      (dynamic-parse-action-and-expression
       (dynamic-parse-expression* env args))
      (error 'dynamic-parse-and "Not a list of arguments: ~s" args)))


; dynamic-parse-or

(define (dynamic-parse-or env args)
  (if (list? args)
      (dynamic-parse-action-or-expression
       (dynamic-parse-expression* env args))
      (error 'dynamic-parse-or "Not a list of arguments: ~s" args)))


; dynamic-parse-case

(define (dynamic-parse-case env args)
  (if (and (list? args) (> (length args) 1))
      (dynamic-parse-action-case-expression
       (dynamic-parse-expression env (car args))
       (map (lambda (e)
               (dynamic-parse-case-clause env e))
             (cdr args)))
      (error 'dynamic-parse-case "Not a list of clauses: ~s" args)))

; dynamic-parse-case-clause

(define (dynamic-parse-case-clause env e)
  (if (pair? e)
      (cons
       (cond
        ((eqv? (car e) 'else)
         (list (dynamic-parse-action-empty)))
        ((list? (car e))
         (map dynamic-parse-datum (car e)))
        (else (error 'dynamic-parse-case-clause "Not a datum list: ~s" (car e))))
       (dynamic-parse-body env (cdr e)))
      (error 'dynamic-parse-case-clause "Not case clause: ~s" e)))


; dynamic-parse-let

(define (dynamic-parse-let env args)
  (if (pair? args)
      (if (symbol? (car args))
          (dynamic-parse-named-let env args)
          (dynamic-parse-normal-let env args))
      (error 'dynamic-parse-let "Illegal bindings/body: ~s" args)))


; dynamic-parse-normal-let

(define (dynamic-parse-normal-let env args)
  ;; parses "normal" let-expressions
  (let* ((bindings (car args))
         (body (cdr args))
         (env-ast (dynamic-parse-parallel-bindings env bindings))
         (nenv (car env-ast))
         (bresults (cdr env-ast)))
    (dynamic-parse-action-let-expression
     bresults
     (dynamic-parse-body (extend-env-with-env env nenv) body))))

; dynamic-parse-named-let

(define (dynamic-parse-named-let env args)
  ;; parses a named let-expression
  (if (pair? (cdr args))
      (let* ((variable (car args))
             (bindings (cadr args))
             (body (cddr args))
             (vbind-vres (dynamic-parse-formal dynamic-empty-env variable))
             (vbind (car vbind-vres))
             (vres (cdr vbind-vres))
             (env-ast (dynamic-parse-parallel-bindings env bindings))
             (nenv (car env-ast))
             (bresults (cdr env-ast)))
        (dynamic-parse-action-named-let-expression
         vres bresults
         (dynamic-parse-body (extend-env-with-env 
                      (extend-env-with-binding env vbind)
                      nenv) body)))
      (error 'dynamic-parse-named-let "Illegal named let-expression: ~s" args)))


; dynamic-parse-parallel-bindings

(define (dynamic-parse-parallel-bindings env bindings)
  ; returns a pair consisting of an environment
  ; and a list of pairs (variable . asg)
  ; ***Note***: the list of pairs is returned in reverse unzipped form!
  (if (list-of-list-of-2s? bindings)
      (let* ((env-formals-asg
             (dynamic-parse-formal* (map car bindings)))
            (nenv (car env-formals-asg))
            (bresults (cdr env-formals-asg))
            (exprs-asg
             (dynamic-parse-expression* env (map cadr bindings))))
        (cons nenv (cons bresults exprs-asg)))
      (error 'dynamic-parse-parallel-bindings
             "Not a list of bindings: ~s" bindings)))


; dynamic-parse-let*

(define (dynamic-parse-let* env args)
  (if (pair? args)
      (let* ((bindings (car args))
             (body (cdr args))
             (env-ast (dynamic-parse-sequential-bindings env bindings))
             (nenv (car env-ast))
             (bresults (cdr env-ast)))
        (dynamic-parse-action-let*-expression
         bresults
         (dynamic-parse-body (extend-env-with-env env nenv) body)))
      (error 'dynamic-parse-let* "Illegal bindings/body: ~s" args)))

; dynamic-parse-sequential-bindings

(define (dynamic-parse-sequential-bindings env bindings)
  ; returns a pair consisting of an environment
  ; and a list of pairs (variable . asg)
  ;; ***Note***: the list of pairs is returned in reverse unzipped form!
  (letrec
      ((psb
        (lambda (f-env c-env var-defs expr-asgs binds)
          ;; f-env: forbidden environment
          ;; c-env: constructed environment
          ;; var-defs: results of formals
          ;; expr-asgs: results of corresponding expressions
          ;; binds: reminding bindings to process
          (cond
           ((null? binds)
            (cons f-env (cons var-defs expr-asgs)))
           ((pair? binds)
            (let ((fst-bind (car binds)))
              (if (list-of-2? fst-bind)
                  (let* ((fbinding-bres
                          (dynamic-parse-formal f-env (car fst-bind)))
                         (fbind (car fbinding-bres))
                         (bres (cdr fbinding-bres))
                         (new-expr-asg
                          (dynamic-parse-expression c-env (cadr fst-bind))))
                    (psb
                     (extend-env-with-binding f-env fbind)
                     (extend-env-with-binding c-env fbind)
                     (cons bres var-defs)
                     (cons new-expr-asg expr-asgs)
                     (cdr binds)))
                  (error 'dynamic-parse-sequential-bindings
                         "Illegal binding: ~s" fst-bind))))
           (else (error 'dynamic-parse-sequential-bindings
                        "Illegal bindings: ~s" binds))))))
    (let ((env-vdefs-easgs (psb dynamic-empty-env env '() '() bindings)))
      (cons (car env-vdefs-easgs)
            (cons (reverse (cadr env-vdefs-easgs))
                  (reverse (cddr env-vdefs-easgs)))))))


; dynamic-parse-letrec

(define (dynamic-parse-letrec env args)
  (if (pair? args)
      (let* ((bindings (car args))
             (body (cdr args))
             (env-ast (dynamic-parse-recursive-bindings env bindings))
             (nenv (car env-ast))
             (bresults (cdr env-ast)))
        (dynamic-parse-action-letrec-expression
          bresults
          (dynamic-parse-body (extend-env-with-env env nenv) body)))
      (error 'dynamic-parse-letrec "Illegal bindings/body: ~s" args)))

; dynamic-parse-recursive-bindings

(define (dynamic-parse-recursive-bindings env bindings)
  ;; ***Note***: the list of pairs is returned in reverse unzipped form!
  (if (list-of-list-of-2s? bindings)
      (let* ((env-formals-asg
              (dynamic-parse-formal* (map car bindings)))
             (formals-env
              (car env-formals-asg))
             (formals-res
              (cdr env-formals-asg))
             (exprs-asg
              (dynamic-parse-expression*
               (extend-env-with-env env formals-env)
               (map cadr bindings))))
        (cons
         formals-env
         (cons formals-res exprs-asg)))
      (error 'dynamic-parse-recursive-bindings "Illegal bindings: ~s" bindings)))


; dynamic-parse-do

(define (dynamic-parse-do env args)
  ;; parses do-expressions
  ;; ***Note***: Not implemented!
  (error 'dynamic-parse-do "Nothing yet..."))

; dynamic-parse-quasiquote

(define (dynamic-parse-quasiquote env args)
  ;; ***Note***: Not implemented!
  (error 'dynamic-parse-quasiquote "Nothing yet..."))


;; Command

; dynamic-parse-command

(define (dynamic-parse-command env c)
  (if (pair? c)
      (let ((op (car c))
            (args (cdr c)))
        (case op
         ((define) (dynamic-parse-define env args))
;        ((begin) (dynamic-parse-command* env args))  ;; AKW
         ((begin) (dynamic-parse-action-begin-expression (dynamic-parse-command* env args)))
         (else (dynamic-parse-expression env c))))
      (dynamic-parse-expression env c)))


; dynamic-parse-command*

(define (dynamic-parse-command* env commands)
  ;; parses a sequence of commands
  (if (list? commands)
      (map (lambda (command) (dynamic-parse-command env command)) commands)
      (error 'dynamic-parse-command* "Invalid sequence of commands: ~s" commands)))


; dynamic-parse-define

(define (dynamic-parse-define env args)
  ;; three cases -- see IEEE Scheme, sect. 5.2
  ;; ***Note***: the parser admits forms (define (x . y) ...)
  ;; ***Note***: Variables are treated as applied occurrences!
  (if (pair? args)
      (let ((pattern (car args))
            (exp-or-body (cdr args)))
        (cond
         ((symbol? pattern)
          (if (list-of-1? exp-or-body)
              (dynamic-parse-action-definition
               (dynamic-parse-variable env pattern)
               (dynamic-parse-expression env (car exp-or-body)))
              (error 'dynamic-parse-define "Not a single expression: ~s" exp-or-body)))
         ((pair? pattern)
          (let* ((function-name (car pattern))
                 (function-arg-names (cdr pattern))
                 (env-ast (dynamic-parse-formals function-arg-names))
                 (formals-env (car env-ast))
                 (formals-ast (cdr env-ast)))
            (dynamic-parse-action-function-definition
             (dynamic-parse-variable env function-name)
             formals-ast
             (dynamic-parse-body (extend-env-with-env env formals-env) exp-or-body))))
         (else (error 'dynamic-parse-define "Not a valid pattern: ~s" pattern))))
      (error 'dynamic-parse-define "Not a valid definition: ~s" args)))

;; Auxiliary routines

; forall?

(define (forall? pred list)
  (if (null? list)
      #t
      (and (pred (car list)) (forall? pred (cdr list)))))

; list-of-1?

(define (list-of-1? l)
  (and (pair? l) (null? (cdr l))))

; list-of-2?

(define (list-of-2? l)
  (and (pair? l) (pair? (cdr l)) (null? (cddr l))))

; list-of-3?

(define (list-of-3? l)
  (and (pair? l) (pair? (cdr l)) (pair? (cddr l)) (null? (cdddr l))))

; list-of-list-of-2s?

(define (list-of-list-of-2s? e)
  (cond
   ((null? e)
    #t)
   ((pair? e)
    (and (list-of-2? (car e)) (list-of-list-of-2s? (cdr e))))
   (else #f)))


;; File processing

; dynamic-parse-from-port

(define (dynamic-parse-from-port port)
  (let ((next-input (read port)))
    (if (eof-object? next-input)
        '()
        (dynamic-parse-action-commands
         (dynamic-parse-command dynamic-empty-env next-input)
         (dynamic-parse-from-port port)))))

; dynamic-parse-file

(define (dynamic-parse-file file-name)
  (let ((input-port (open-input-file file-name)))
    (dynamic-parse-from-port input-port)))
;----------------------------------------------------------------------------
; Implementation of Union/find data structure in Scheme
;----------------------------------------------------------------------------

;; for union/find the following attributes are necessary: rank, parent 
;; (see Tarjan, "Data structures and network algorithms", 1983)
;; In the Scheme realization an element is represented as a single
;; cons cell; its address is the element itself; the car field contains 
;; the parent, the cdr field is an address for a cons
;; cell containing the rank (car field) and the information (cdr field)


;; general union/find data structure
;; 
;; gen-element: Info -> Elem
;; find: Elem -> Elem
;; link: Elem! x Elem! -> Elem
;; asymm-link: Elem! x Elem! -> Elem
;; info: Elem -> Info
;; set-info!: Elem! x Info -> Void


(define (gen-element info)
  ; generates a new element: the parent field is initialized to '(),
  ; the rank field to 0
  (cons '() (cons 0 info)))

(define info (lambda (l) (cddr l)))
  ; returns the information stored in an element

(define (set-info! elem info)
  ; sets the info-field of elem to info