scheme.scm

Scheme跨平台编译器

;;; SCHEME -- A Scheme interpreter evaluating a sorting routine, written by Marc Feeley.
;
; 08/06/01 (felix): renamed "macro?" to "macro?2" because MZC can't
; handle redefinitions of primitives.
; 18/07/01 (felix): 100 iterations
;

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

(define (scheme-eval expr)
  (let ((code (scheme-comp expr scheme-global-environment)))
    (code #f)))

(define scheme-global-environment
  (cons '()   ; environment chain
        '())) ; macros

(define (scheme-add-macro name proc)
  (set-cdr! scheme-global-environment
    (cons (cons name proc) (cdr scheme-global-environment)))
  name)

(define (scheme-error msg . args)
  (fatal-error msg args))

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

(define (lst->vector l)
  (let* ((n (length l))
         (v (make-vector n)))
    (let loop ((l l) (i 0))
      (if (pair? l)
        (begin
          (vector-set! v i (car l))
          (loop (cdr l) (+ i 1)))
        v))))

(define (vector->lst v)
  (let loop ((l '()) (i (- (vector-length v) 1)))
    (if (< i 0)
      l
      (loop (cons (vector-ref v i) l) (- i 1)))))

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

(define scheme-syntactic-keywords
  '(quote quasiquote unquote unquote-splicing
    lambda if set! cond => else and or
    case let let* letrec begin do define
    define-macro))

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

(define (push-frame frame env)
  (if (null? frame)
    env
    (cons (cons (car env) frame) (cdr env))))

(define (lookup-var name env)
  (let loop1 ((chain (car env)) (up 0))
    (if (null? chain)
      name
      (let loop2 ((chain chain)
                  (up up)
                  (frame (cdr chain))
                  (over 1))
        (cond ((null? frame)
               (loop1 (car chain) (+ up 1)))
              ((eq? (car frame) name)
               (cons up over))
              (else
               (loop2 chain up (cdr frame) (+ over 1))))))))

(define (macro?2 name env)
  (assq name (cdr env)))

(define (push-macro name proc env)
  (cons (car env) (cons (cons name proc) (cdr env))))

(define (lookup-macro name env)
  (cdr (assq name (cdr env))))

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

(define (variable x)
  (if (not (symbol? x))
    (scheme-error "Identifier expected" x))
  (if (memq x scheme-syntactic-keywords)
    (scheme-error "Variable name can not be a syntactic keyword" x)))

(define (shape form n)
  (let loop ((form form) (n n) (l form))
    (cond ((<= n 0))
          ((pair? l)
           (loop form (- n 1) (cdr l)))
          (else
           (scheme-error "Ill-constructed form" form)))))

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

(define (macro-expand expr env)
  (apply (lookup-macro (car expr) env) (cdr expr)))

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

(define (comp-var expr env)
  (variable expr)
  (gen-var-ref (lookup-var expr env)))

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

(define (comp-self-eval expr env)
  (gen-cst expr))

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

(define (comp-quote expr env)
  (shape expr 2)
  (gen-cst (cadr expr)))

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

(define (comp-quasiquote expr env)
  (comp-quasiquotation (cadr expr) 1 env))

(define (comp-quasiquotation form level env)
  (cond ((= level 0)
         (scheme-comp form env))
        ((pair? form)
         (cond
           ((eq? (car form) 'quasiquote)
            (comp-quasiquotation-list form (+ level 1) env))
           ((eq? (car form) 'unquote)
            (if (= level 1)
              (scheme-comp (cadr form) env)
              (comp-quasiquotation-list form (- level 1) env)))
           ((eq? (car form) 'unquote-splicing)
            (if (= level 1)
              (scheme-error "Ill-placed 'unquote-splicing'" form))
            (comp-quasiquotation-list form (- level 1) env))
           (else
            (comp-quasiquotation-list form level env))))
        ((vector? form)
         (gen-vector-form
           (comp-quasiquotation-list (vector->lst form) level env)))
        (else
         (gen-cst form))))

(define (comp-quasiquotation-list l level env)
  (if (pair? l)
    (let ((first (car l)))
      (if (= level 1)
        (if (unquote-splicing? first)
          (begin
            (shape first 2)
            (gen-append-form (scheme-comp (cadr first) env)
                             (comp-quasiquotation (cdr l) 1 env)))
          (gen-cons-form (comp-quasiquotation first level env)
                         (comp-quasiquotation (cdr l) level env)))
        (gen-cons-form (comp-quasiquotation first level env)
                       (comp-quasiquotation (cdr l) level env))))
    (comp-quasiquotation l level env)))

(define (unquote-splicing? x)
  (if (pair? x)
    (if (eq? (car x) 'unquote-splicing) #t #f)
    #f))

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

(define (comp-unquote expr env)
  (scheme-error "Ill-placed 'unquote'" expr))

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

(define (comp-unquote-splicing expr env)
  (scheme-error "Ill-placed 'unquote-splicing'" expr))

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

(define (comp-set! expr env)
  (shape expr 3)
  (variable (cadr expr))
  (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env)))

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

(define (comp-lambda expr env)
  (shape expr 3)
  (let ((parms (cadr expr)))
    (let ((frame (parms->frame parms)))
      (let ((nb-vars (length frame))
            (code (comp-body (cddr expr) (push-frame frame env))))
        (if (rest-param? parms)
          (gen-lambda-rest nb-vars code)
          (gen-lambda nb-vars code))))))

(define (parms->frame parms)
  (cond ((null? parms)
         '())
        ((pair? parms)
         (let ((x (car parms)))
           (variable x)
           (cons x (parms->frame (cdr parms)))))
        (else
         (variable parms)
         (list parms))))

(define (rest-param? parms)
  (cond ((pair? parms)
         (rest-param? (cdr parms)))
        ((null? parms)
         #f)
        (else
         #t)))

(define (comp-body body env)

  (define (letrec-defines vars vals body env)
    (if (pair? body)

      (let ((expr (car body)))
        (cond ((not (pair? expr))
               (letrec-defines* vars vals body env))
              ((macro?2 (car expr) env)
               (letrec-defines vars
                               vals
                               (cons (macro-expand expr env) (cdr body))
                               env))
              (else
               (cond
                 ((eq? (car expr) 'begin)
                  (letrec-defines vars
                                  vals
                                  (append (cdr expr) (cdr body))
                                  env))
                 ((eq? (car expr) 'define)
                  (let ((x (definition-name expr)))
                    (variable x)
                    (letrec-defines (cons x vars)
                                    (cons (definition-value expr) vals)
                                    (cdr body)
                                    env)))
                 ((eq? (car expr) 'define-macro)
                  (let ((x (definition-name expr)))
                    (letrec-defines vars
                                    vals
                                    (cdr body)
                                    (push-macro
                                      x
                                      (scheme-eval (definition-value expr))
                                      env))))
                 (else
                  (letrec-defines* vars vals body env))))))

      (scheme-error "Body must contain at least one evaluable expression")))

  (define (letrec-defines* vars vals body env)
    (if (null? vars)
      (comp-sequence body env)
      (comp-letrec-aux vars vals body env)))

  (letrec-defines '() '() body env))

(define (definition-name expr)
  (shape expr 3)
  (let ((pattern (cadr expr)))
    (let ((name (if (pair? pattern) (car pattern) pattern)))
      (if (not (symbol? name))
        (scheme-error "Identifier expected" name))
      name)))

(define (definition-value expr)
  (let ((pattern (cadr expr)))
    (if (pair? pattern)
      (cons 'lambda (cons (cdr pattern) (cddr expr)))
      (caddr expr))))

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

(define (comp-if expr env)
  (shape expr 3)
  (let ((code1 (scheme-comp (cadr expr) env))
        (code2 (scheme-comp (caddr expr) env)))
    (if (pair? (cdddr expr))
      (gen-if code1 code2 (scheme-comp (cadddr expr) env))
      (gen-when code1 code2))))

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

(define (comp-cond expr env)
  (comp-cond-aux (cdr expr) env))

(define (comp-cond-aux clauses env)
  (if (pair? clauses)
    (let ((clause (car clauses)))
      (shape clause 1)
      (cond ((eq? (car clause) 'else)
             (shape clause 2)
             (comp-sequence (cdr clause) env))
            ((not (pair? (cdr clause)))
             (gen-or (scheme-comp (car clause) env)
                     (comp-cond-aux (cdr clauses) env)))
            ((eq? (cadr clause) '=>)
             (shape clause 3)
             (gen-cond-send (scheme-comp (car clause) env)
                            (scheme-comp (caddr clause) env)
                            (comp-cond-aux (cdr clauses) env)))
            (else
             (gen-if (scheme-comp (car clause) env)
                     (comp-sequence (cdr clause) env)
                     (comp-cond-aux (cdr clauses) env)))))
    (gen-cst '())))

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

(define (comp-and expr env)
  (let ((rest (cdr expr)))
    (if (pair? rest) (comp-and-aux rest env) (gen-cst #t))))

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

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

(define (comp-or expr env)
  (let ((rest (cdr expr)))
    (if (pair? rest) (comp-or-aux rest env) (gen-cst #f))))

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

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

(define (comp-case expr env)
  (shape expr 3)
  (gen-case (scheme-comp (cadr expr) env)
            (comp-case-aux (cddr expr) env)))

(define (comp-case-aux clauses env)
  (if (pair? clauses)
    (let ((clause (car clauses)))
      (shape clause 2)
      (if (eq? (car clause) 'else)
        (gen-case-else (comp-sequence (cdr clause) env))
        (gen-case-clause (car clause)
                         (comp-sequence (cdr clause) env)
                         (comp-case-aux (cdr clauses) env))))
    (gen-case-else (gen-cst '()))))

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

(define (comp-let expr env)
  (shape expr 3)
  (let ((x (cadr expr)))
    (cond ((symbol? x)
           (shape expr 4)