scheme.scm

Scheme跨平台编译器

           (let ((y (caddr expr)))
             (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr)))))
               (scheme-comp (cons (list 'letrec (list (list x proc)) x)
                                  (bindings->vals y))
                            env))))
          ((pair? x)
           (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr)))
                              (bindings->vals x))
                        env))
          (else
           (comp-body (cddr expr) env)))))

(define (bindings->vars bindings)
  (if (pair? bindings)
    (let ((binding (car bindings)))
      (shape binding 2)
      (let ((x (car binding)))
        (variable x)
        (cons x (bindings->vars (cdr bindings)))))
    '()))

(define (bindings->vals bindings)
  (if (pair? bindings)
    (let ((binding (car bindings)))
      (cons (cadr binding) (bindings->vals (cdr bindings))))
    '()))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (comp-let* expr env)
  (shape expr 3)
  (let ((bindings (cadr expr)))
    (if (pair? bindings)
      (scheme-comp (list 'let
                         (list (car bindings))
                         (cons 'let* (cons (cdr bindings) (cddr expr))))
                   env)
      (comp-body (cddr expr) env))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (comp-letrec expr env)
  (shape expr 3)
  (let ((bindings (cadr expr)))
    (comp-letrec-aux (bindings->vars bindings)
                     (bindings->vals bindings)
                     (cddr expr)
                     env)))

(define (comp-letrec-aux vars vals body env)
  (if (pair? vars)
    (let ((new-env (push-frame vars env)))
      (gen-letrec (comp-vals vals new-env)
                  (comp-body body new-env)))
    (comp-body body env)))

(define (comp-vals l env)
  (if (pair? l)
    (cons (scheme-comp (car l) env) (comp-vals (cdr l) env))
    '()))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (comp-begin expr env)
  (shape expr 2)
  (comp-sequence (cdr expr) env))

(define (comp-sequence exprs env)
  (if (pair? exprs)
    (comp-sequence-aux exprs env)
    (gen-cst '())))

(define (comp-sequence-aux exprs env)
  (let ((code (scheme-comp (car exprs) env))
        (rest (cdr exprs)))
    (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (comp-do expr env)
  (shape expr 3)
  (let ((bindings (cadr expr))
        (exit (caddr expr)))
    (shape exit 1)
    (let* ((vars (bindings->vars bindings))
           (new-env1 (push-frame '(#f) env))
           (new-env2 (push-frame vars new-env1)))
      (gen-letrec
        (list
          (gen-lambda
            (length vars)
            (gen-if
              (scheme-comp (car exit) new-env2)
              (comp-sequence (cdr exit) new-env2)
              (gen-sequence
                (comp-sequence (cdddr expr) new-env2)
                (gen-combination
                  (gen-var-ref '(1 . 1))
                  (comp-vals (bindings->steps bindings) new-env2))))))
        (gen-combination
          (gen-var-ref '(0 . 1))
          (comp-vals (bindings->vals bindings) new-env1))))))

(define (bindings->steps bindings)
  (if (pair? bindings)
    (let ((binding (car bindings)))
      (cons (if (pair? (cddr binding)) (caddr binding) (car binding))
            (bindings->steps (cdr bindings))))
    '()))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (comp-define expr env)
  (shape expr 3)
  (let ((pattern (cadr expr)))
    (let ((x (if (pair? pattern) (car pattern) pattern)))
      (variable x)
      (gen-sequence
        (gen-var-set (lookup-var x env)
                     (scheme-comp (if (pair? pattern)
                                    (cons 'lambda (cons (cdr pattern) (cddr expr)))
                                    (caddr expr))
                                  env))
        (gen-cst x)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (comp-define-macro expr env)
  (let ((x (definition-name expr)))
    (gen-macro x (scheme-eval (definition-value expr)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (comp-combination expr env)
  (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env)))

;------------------------------------------------------------------------------

(define (gen-var-ref var)
  (if (pair? var)
    (gen-rte-ref (car var) (cdr var))
    (gen-glo-ref (scheme-global-var var))))

(define (gen-rte-ref up over)
  (case up
    ((0)  (gen-slot-ref-0 over))
    ((1)  (gen-slot-ref-1 over))
    (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over)))))

(define (gen-slot-ref-0 i)
  (case i
    ((0)  (lambda (rte) (vector-ref rte 0)))
    ((1)  (lambda (rte) (vector-ref rte 1)))
    ((2)  (lambda (rte) (vector-ref rte 2)))
    ((3)  (lambda (rte) (vector-ref rte 3)))
    (else (lambda (rte) (vector-ref rte i)))))

(define (gen-slot-ref-1 i)
  (case i
    ((0)  (lambda (rte) (vector-ref (vector-ref rte 0) 0)))
    ((1)  (lambda (rte) (vector-ref (vector-ref rte 0) 1)))
    ((2)  (lambda (rte) (vector-ref (vector-ref rte 0) 2)))
    ((3)  (lambda (rte) (vector-ref (vector-ref rte 0) 3)))
    (else (lambda (rte) (vector-ref (vector-ref rte 0) i)))))

(define (gen-slot-ref-up-2 code)
  (lambda (rte) (code (vector-ref (vector-ref rte 0) 0))))

(define (gen-glo-ref i)
  (lambda (rte) (scheme-global-var-ref i)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-cst val)
  (case val
    ((()) (lambda (rte) '()))
    ((#f) (lambda (rte) #f))
    ((#t) (lambda (rte) #t))
    ((-2) (lambda (rte) -2))
    ((-1) (lambda (rte) -1))
    ((0)  (lambda (rte) 0))
    ((1)  (lambda (rte) 1))
    ((2)  (lambda (rte) 2))
    (else (lambda (rte) val))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-append-form code1 code2)
  (lambda (rte) (append (code1 rte) (code2 rte))))

(define (gen-cons-form code1 code2)
  (lambda (rte) (cons (code1 rte) (code2 rte))))

(define (gen-vector-form code)
  (lambda (rte) (lst->vector (code rte))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-var-set var code)
  (if (pair? var)
    (gen-rte-set (car var) (cdr var) code)
    (gen-glo-set (scheme-global-var var) code)))

(define (gen-rte-set up over code)
  (case up
    ((0)  (gen-slot-set-0 over code))
    ((1)  (gen-slot-set-1 over code))
    (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code))))

(define (gen-slot-set-0 i code)
  (case i
    ((0)  (lambda (rte) (vector-set! rte 0 (code rte))))
    ((1)  (lambda (rte) (vector-set! rte 1 (code rte))))
    ((2)  (lambda (rte) (vector-set! rte 2 (code rte))))
    ((3)  (lambda (rte) (vector-set! rte 3 (code rte))))
    (else (lambda (rte) (vector-set! rte i (code rte))))))

(define (gen-slot-set-1 i code)
  (case i
    ((0)  (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte))))
    ((1)  (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte))))
    ((2)  (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte))))
    ((3)  (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte))))
    (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte))))))

(define (gen-slot-set-n up i code)
  (case i
    ((0)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte))))
    ((1)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte))))
    ((2)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte))))
    ((3)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte))))
    (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte))))))

(define (gen-glo-set i code)
  (lambda (rte) (scheme-global-var-set! i (code rte))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-lambda-rest nb-vars body)
  (case nb-vars
    ((1)  (gen-lambda-1-rest body))
    ((2)  (gen-lambda-2-rest body))
    ((3)  (gen-lambda-3-rest body))
    (else (gen-lambda-n-rest nb-vars body))))

(define (gen-lambda-1-rest body)
  (lambda (rte)
    (lambda a
      (body (vector rte a)))))

(define (gen-lambda-2-rest body)
  (lambda (rte)
    (lambda (a . b)
      (body (vector rte a b)))))

(define (gen-lambda-3-rest body)
  (lambda (rte)
    (lambda (a b . c)
      (body (vector rte a b c)))))

(define (gen-lambda-n-rest nb-vars body)
  (lambda (rte)
    (lambda (a b c . d)
      (let ((x (make-vector (+ nb-vars 1))))
        (vector-set! x 0 rte)
        (vector-set! x 1 a)
        (vector-set! x 2 b)
        (vector-set! x 3 c)
        (let loop ((n nb-vars) (x x) (i 4) (l d))
          (if (< i n)
            (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))
            (vector-set! x i l)))
        (body x)))))

(define (gen-lambda nb-vars body)
  (case nb-vars
    ((0)  (gen-lambda-0 body))
    ((1)  (gen-lambda-1 body))
    ((2)  (gen-lambda-2 body))
    ((3)  (gen-lambda-3 body))
    (else (gen-lambda-n nb-vars body))))

(define (gen-lambda-0 body)
  (lambda (rte)
    (lambda ()
      (body rte))))

(define (gen-lambda-1 body)
  (lambda (rte)
    (lambda (a)
      (body (vector rte a)))))

(define (gen-lambda-2 body)
  (lambda (rte)
    (lambda (a b)
      (body (vector rte a b)))))

(define (gen-lambda-3 body)
  (lambda (rte)
    (lambda (a b c)
      (body (vector rte a b c)))))

(define (gen-lambda-n nb-vars body)
  (lambda (rte)
    (lambda (a b c . d)
      (let ((x (make-vector (+ nb-vars 1))))
        (vector-set! x 0 rte)
        (vector-set! x 1 a)
        (vector-set! x 2 b)
        (vector-set! x 3 c)
        (let loop ((n nb-vars) (x x) (i 4) (l d))
          (if (<= i n)
            (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))))
        (body x)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-sequence code1 code2)
  (lambda (rte) (code1 rte) (code2 rte)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-when code1 code2)
  (lambda (rte)
    (if (code1 rte)
      (code2 rte)
      '())))

(define (gen-if code1 code2 code3)
  (lambda (rte)
    (if (code1 rte)
      (code2 rte)
      (code3 rte))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-cond-send code1 code2 code3)
  (lambda (rte)
    (let ((temp (code1 rte)))
      (if temp
        ((code2 rte) temp)
        (code3 rte)))))
              
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-and code1 code2)
  (lambda (rte)
    (let ((temp (code1 rte)))
      (if temp
        (code2 rte)
        temp))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-or code1 code2)
  (lambda (rte)
    (let ((temp (code1 rte)))
      (if temp
        temp
        (code2 rte)))))