psyntax.ss

MSYS在windows下模拟了一个类unix的终端

      ((self-evaluating? e) (values 'constant #f e w s))
      (else (values 'other #f e w s)))))

(define chi-top
  (lambda (e r w m esew)
    (define-syntax eval-if-c&e
      (syntax-rules ()
        ((_ m e)
         (let ((x e))
           (if (eq? m 'c&e) (top-level-eval-hook x))
           x))))
    (call-with-values
      (lambda () (syntax-type e r w no-source #f))
      (lambda (type value e w s)
        (case type
          ((begin-form)
           (syntax-case e ()
             ((_) (chi-void))
             ((_ e1 e2 ...)
              (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew))))
          ((local-syntax-form)
           (chi-local-syntax value e r w s
             (lambda (body r w s)
               (chi-top-sequence body r w s m esew))))
          ((eval-when-form)
           (syntax-case e ()
             ((_ (x ...) e1 e2 ...)
              (let ((when-list (chi-when-list e (syntax (x ...)) w))
                    (body (syntax (e1 e2 ...))))
                (cond
                  ((eq? m 'e)
                   (if (memq 'eval when-list)
                       (chi-top-sequence body r w s 'e '(eval))
                       (chi-void)))
                  ((memq 'load when-list)
                   (if (or (memq 'compile when-list)
                           (and (eq? m 'c&e) (memq 'eval when-list)))
                       (chi-top-sequence body r w s 'c&e '(compile load))
                       (if (memq m '(c c&e))
                           (chi-top-sequence body r w s 'c '(load))
                           (chi-void))))
                  ((or (memq 'compile when-list)
                       (and (eq? m 'c&e) (memq 'eval when-list)))
                   (top-level-eval-hook
                     (chi-top-sequence body r w s 'e '(eval)))
                   (chi-void))
                  (else (chi-void)))))))
          ((define-syntax-form)
           (let ((n (id-var-name value w)) (r (macros-only-env r)))
             (case m
               ((c)
                (if (memq 'compile esew)
                    (let ((e (chi-install-global n (chi e r w))))
                      (top-level-eval-hook e)
                      (if (memq 'load esew) e (chi-void)))
                    (if (memq 'load esew)
                        (chi-install-global n (chi e r w))
                        (chi-void))))
               ((c&e)
                (let ((e (chi-install-global n (chi e r w))))
                  (top-level-eval-hook e)
                  e))
               (else
                (if (memq 'eval esew)
                    (top-level-eval-hook
                      (chi-install-global n (chi e r w))))
                (chi-void)))))
          ((define-form)
           (let ((n (id-var-name value w)))
             (case (binding-type (lookup n r))
               ((global)
                (eval-if-c&e m
                  (build-global-definition s n (chi e r w))))
               ((displaced-lexical)
                (syntax-error (wrap value w) "identifier out of context"))
               (else (syntax-error (wrap value w)
                       "cannot define keyword at top level")))))
          (else (eval-if-c&e m (chi-expr type value e r w s))))))))

(define chi
  (lambda (e r w)
    (call-with-values
      (lambda () (syntax-type e r w no-source #f))
      (lambda (type value e w s)
        (chi-expr type value e r w s)))))

(define chi-expr
  (lambda (type value e r w s)
    (case type
      ((lexical)
       (build-lexical-reference 'value s value))
      ((core) (value e r w s))
      ((lexical-call)
       (chi-application
         (build-lexical-reference 'fun (source-annotation (car e)) value)
         e r w s))
      ((global-call)
       (chi-application
         (build-global-reference (source-annotation (car e)) value)
         e r w s))
      ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
      ((global) (build-global-reference s value))
      ((call) (chi-application (chi (car e) r w) e r w s))
      ((begin-form)
       (syntax-case e ()
         ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
      ((local-syntax-form)
       (chi-local-syntax value e r w s chi-sequence))
      ((eval-when-form)
       (syntax-case e ()
         ((_ (x ...) e1 e2 ...)
          (let ((when-list (chi-when-list e (syntax (x ...)) w)))
            (if (memq 'eval when-list)
                (chi-sequence (syntax (e1 e2 ...)) r w s)
                (chi-void))))))
      ((define-form define-syntax-form)
       (syntax-error (wrap value w) "invalid context for definition of"))
      ((syntax)
       (syntax-error (source-wrap e w s)
         "reference to pattern variable outside syntax form"))
      ((displaced-lexical)
       (syntax-error (source-wrap e w s)
         "reference to identifier outside its scope"))
      (else (syntax-error (source-wrap e w s))))))

(define chi-application
  (lambda (x e r w s)
    (syntax-case e ()
      ((e0 e1 ...)
       (build-application s x
         (map (lambda (e) (chi e r w)) (syntax (e1 ...))))))))

(define chi-macro
  (lambda (p e r w rib)
    (define rebuild-macro-output
      (lambda (x m)
        (cond ((pair? x)
               (cons (rebuild-macro-output (car x) m)
                     (rebuild-macro-output (cdr x) m)))
              ((syntax-object? x)
               (let ((w (syntax-object-wrap x)))
                 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
                   (make-syntax-object (syntax-object-expression x)
                     (if (and (pair? ms) (eq? (car ms) the-anti-mark))
                         (make-wrap (cdr ms)
                           (if rib (cons rib (cdr s)) (cdr s)))
                         (make-wrap (cons m ms)
                           (if rib
                               (cons rib (cons 'shift s))
                               (cons 'shift s))))))))
              ((vector? x)
               (let* ((n (vector-length x)) (v (make-vector n)))
                 (do ((i 0 (fx+ i 1)))
                     ((fx= i n) v)
                     (vector-set! v i
                       (rebuild-macro-output (vector-ref x i) m)))))
              ((symbol? x)
               (syntax-error x "encountered raw symbol in macro output"))
              (else x))))
    (rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark))))

(define chi-body
  ;; In processing the forms of the body, we create a new, empty wrap.
  ;; This wrap is augmented (destructively) each time we discover that
  ;; the next form is a definition.  This is done:
  ;;
  ;;   (1) to allow the first nondefinition form to be a call to
  ;;       one of the defined ids even if the id previously denoted a
  ;;       definition keyword or keyword for a macro expanding into a
  ;;       definition;
  ;;   (2) to prevent subsequent definition forms (but unfortunately
  ;;       not earlier ones) and the first nondefinition form from
  ;;       confusing one of the bound identifiers for an auxiliary
  ;;       keyword; and
  ;;   (3) so that we do not need to restart the expansion of the
  ;;       first nondefinition form, which is problematic anyway
  ;;       since it might be the first element of a begin that we
  ;;       have just spliced into the body (meaning if we restarted,
  ;;       we'd really need to restart with the begin or the macro
  ;;       call that expanded into the begin, and we'd have to give
  ;;       up allowing (begin <defn>+ <expr>+), which is itself
  ;;       problematic since we don't know if a begin contains only
  ;;       definitions until we've expanded it).
  ;;
  ;; Before processing the body, we also create a new environment
  ;; containing a placeholder for the bindings we will add later and
  ;; associate this environment with each form.  In processing a
  ;; let-syntax or letrec-syntax, the associated environment may be
  ;; augmented with local keyword bindings, so the environment may
  ;; be different for different forms in the body.  Once we have
  ;; gathered up all of the definitions, we evaluate the transformer
  ;; expressions and splice into r at the placeholder the new variable
  ;; and keyword bindings.  This allows let-syntax or letrec-syntax
  ;; forms local to a portion or all of the body to shadow the
  ;; definition bindings.
  ;;
  ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
  ;; into the body.
  ;;
  ;; outer-form is fully wrapped w/source
  (lambda (body outer-form r w)
    (let* ((r (cons '("placeholder" . (placeholder)) r))
           (ribcage (make-empty-ribcage))
           (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
      (let parse ((body (map (lambda (x) (cons r (wrap x w))) body))
                  (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
        (if (null? body)
            (syntax-error outer-form "no expressions in body")
            (let ((e (cdar body)) (er (caar body)))
              (call-with-values
                (lambda () (syntax-type e er empty-wrap no-source ribcage))
                (lambda (type value e w s)
                  (case type
                    ((define-form)
                     (let ((id (wrap value w)) (label (gen-label)))
                       (let ((var (gen-var id)))
                         (extend-ribcage! ribcage id label)
                         (parse (cdr body)
                           (cons id ids) (cons label labels)
                           (cons var vars) (cons (cons er (wrap e w)) vals)
                           (cons (make-binding 'lexical var) bindings)))))
                    ((define-syntax-form)
                     (let ((id (wrap value w)) (label (gen-label)))
                       (extend-ribcage! ribcage id label)
                       (parse (cdr body)
                         (cons id ids) (cons label labels)
                         vars vals
                         (cons (make-binding 'macro (cons er (wrap e w)))
                               bindings))))
                    ((begin-form)
                     (syntax-case e ()
                       ((_ e1 ...)
                        (parse (let f ((forms (syntax (e1 ...))))
                                 (if (null? forms)
                                     (cdr body)
                                     (cons (cons er (wrap (car forms) w))
                                           (f (cdr forms)))))
                          ids labels vars vals bindings))))
                    ((local-syntax-form)
                     (chi-local-syntax value e er w s
                       (lambda (forms er w s)
                         (parse (let f ((forms forms))
                                  (if (null? forms)
                                      (cdr body)
                                      (cons (cons er (wrap (car forms) w))
                                            (f (cdr forms)))))
                           ids labels vars vals bindings))))
                    (else ; found a non-definition
                     (if (null? ids)
                         (build-sequence no-source
                           (map (lambda (x)
                                  (chi (cdr x) (car x) empty-wrap))
                                (cons (cons er (source-wrap e w s))
                                      (cdr body))))
                         (begin
                           (if (not (valid-bound-ids? ids))
                               (syntax-error outer-form
                                 "invalid or duplicate identifier in definition"))
                           (let loop ((bs bindings) (er-cache #f) (r-cache #f))
                             (if (not (null? bs))
                                 (let* ((b (car bs)))
                                   (if (eq? (car b) 'macro)
                                       (let* ((er (cadr b))
                                              (r-cache
                                                (if (eq? er er-cache)
                                                    r-cache
                                                    (macros-only-env er))))
                                         (set-cdr! b
                                           (eval-local-transformer
                                             (chi (cddr b) r-cache empty-wrap)))
                                         (loop (cdr bs) er r-cache))
                                       (loop (cdr bs) er-cache r-cache)))))
                           (set-cdr! r (extend-env labels bindings (cdr r)))
                           (build-letrec no-source
                             vars
                             (map (lambda (x)
                                    (chi (cdr x) (car x) empty-wrap))
                                  vals)
                             (build-sequence no-source
                               (map (lambda (x)
                                      (chi (cdr x) (car x) empty-wrap))
                                    (cons (cons er (source-wrap e w s))
                                          (cdr body)))))))))))))))))

(define chi-lambda-clause
  (lambda (e c r w k)
    (syntax-case c ()
      (((id ...) e1 e2 ...)
       (let ((ids (syntax (id ...))))
         (if (not (valid-bound-ids? ids))
             (syntax-error e "invalid parameter list in")
             (let ((labels (gen-labels ids))
                   (new-vars (map gen-var ids)))
               (k new-vars
                  (chi-body (syntax (e1 e2 ...))
                            e
                            (extend-var-env labels new-vars r)
                            (make-binding-wrap ids labels w)))))))
      ((ids e1 e2 ...)
       (let ((old-ids (lambda-var-list (syntax ids))))
         (if (not (valid-bound-ids? old-ids))
             (syntax-error e "invalid parameter list in")
             (let ((labels (gen-labels old-ids))
                   (new-vars (map gen-var old-ids)))
               (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
                    (if (null? ls1)
                        ls2
                        (f (cdr ls1) (cons (car ls1) ls2))))
                  (chi-body (syntax (e1 e2 ...))
                            e
                            (extend-var-env labels new-vars r)
                            (make-binding-wrap old-ids labels w)))))))
      (_ (syntax-error e)))))

(define chi-local-syntax
  (lambda (rec? e r w s k)
    (syntax-case e ()
      ((_ ((id val) ...) e1 e2 ...)
       (let ((ids (syntax (id ...))))
         (if (not (valid-bound-ids? ids))
             (syntax-error e "duplicate bound keyword in")
             (let ((labels (gen-labels ids)))
               (let ((new-w (make-binding-wrap ids labels w)))
                 (k (syntax (e1 e2 ...))
                    (extend-env
                      labels
                      (let ((w (if rec? new-w w))
                            (trans-r (macros-only-env r)))
                        (map (lambda (x)
                               (make-binding 'macro
                                 (eval-local-transformer (chi x trans-r w))))
                             (syntax (val ...))))
                      r)
                    new-w
                    s))))))
      (_ (syntax-error (source-wrap e w s))))))