psyntax.ss

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

(define-syntax new-mark
  (syntax-rules ()
    ((_) (string #\m))))

;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;;; internal definitions, in which the ribcages are built incrementally
(define-syntax make-empty-ribcage
  (syntax-rules ()
    ((_) (make-ribcage '() '() '()))))

(define extend-ribcage!
  ; must receive ids with complete wraps
  (lambda (ribcage id label)
    (set-ribcage-symnames! ribcage
      (cons (unannotate (syntax-object-expression id))
            (ribcage-symnames ribcage)))
    (set-ribcage-marks! ribcage
      (cons (wrap-marks (syntax-object-wrap id))
            (ribcage-marks ribcage)))
    (set-ribcage-labels! ribcage
      (cons label (ribcage-labels ribcage)))))

;;; make-binding-wrap creates vector-based ribcages
(define make-binding-wrap
  (lambda (ids labels w)
    (if (null? ids)
        w
        (make-wrap
          (wrap-marks w)
          (cons
            (let ((labelvec (list->vector labels)))
              (let ((n (vector-length labelvec)))
                (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
                  (let f ((ids ids) (i 0))
                    (if (not (null? ids))
                        (call-with-values
                          (lambda () (id-sym-name&marks (car ids) w))
                          (lambda (symname marks)
                            (vector-set! symnamevec i symname)
                            (vector-set! marksvec i marks)
                            (f (cdr ids) (fx+ i 1))))))
                  (make-ribcage symnamevec marksvec labelvec))))
            (wrap-subst w))))))

(define smart-append
  (lambda (m1 m2)
    (if (null? m2)
        m1
        (append m1 m2))))

(define join-wraps
  (lambda (w1 w2)
    (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
      (if (null? m1)
          (if (null? s1)
              w2
              (make-wrap
                (wrap-marks w2)
                (smart-append s1 (wrap-subst w2))))
          (make-wrap
            (smart-append m1 (wrap-marks w2))
            (smart-append s1 (wrap-subst w2)))))))

(define join-marks
  (lambda (m1 m2)
    (smart-append m1 m2)))

(define same-marks?
  (lambda (x y)
    (or (eq? x y)
        (and (not (null? x))
             (not (null? y))
             (eq? (car x) (car y))
             (same-marks? (cdr x) (cdr y))))))

(define id-var-name
  (lambda (id w)
    (define-syntax first
      (syntax-rules ()
        ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
    (define search
      (lambda (sym subst marks)
        (if (null? subst)
            (values #f marks)
            (let ((fst (car subst)))
              (if (eq? fst 'shift)
                  (search sym (cdr subst) (cdr marks))
                  (let ((symnames (ribcage-symnames fst)))
                    (if (vector? symnames)
                        (search-vector-rib sym subst marks symnames fst)
                        (search-list-rib sym subst marks symnames fst))))))))
    (define search-list-rib
      (lambda (sym subst marks symnames ribcage)
        (let f ((symnames symnames) (i 0))
          (cond
            ((null? symnames) (search sym (cdr subst) marks))
            ((and (eq? (car symnames) sym)
                  (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
             (values (list-ref (ribcage-labels ribcage) i) marks))
            (else (f (cdr symnames) (fx+ i 1)))))))
    (define search-vector-rib
      (lambda (sym subst marks symnames ribcage)
        (let ((n (vector-length symnames)))
          (let f ((i 0))
            (cond
              ((fx= i n) (search sym (cdr subst) marks))
              ((and (eq? (vector-ref symnames i) sym)
                    (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
               (values (vector-ref (ribcage-labels ribcage) i) marks))
              (else (f (fx+ i 1))))))))
    (cond
      ((symbol? id)
       (or (first (search id (wrap-subst w) (wrap-marks w))) id))
      ((syntax-object? id)
        (let ((id (unannotate (syntax-object-expression id)))
              (w1 (syntax-object-wrap id)))
          (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
            (call-with-values (lambda () (search id (wrap-subst w) marks))
              (lambda (new-id marks)
                (or new-id
                    (first (search id (wrap-subst w1) marks))
                    id))))))
      ((annotation? id)
       (let ((id (unannotate id)))
         (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
      (else (error-hook 'id-var-name "invalid id" id)))))

;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.

(define free-id=?
  (lambda (i j)
    (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
         (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))

;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;;; long as the missing portion of the wrap is common to both of the ids
;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))

(define bound-id=?
  (lambda (i j)
    (if (and (syntax-object? i) (syntax-object? j))
        (and (eq? (unannotate (syntax-object-expression i))
                  (unannotate (syntax-object-expression j)))
             (same-marks? (wrap-marks (syntax-object-wrap i))
                  (wrap-marks (syntax-object-wrap j))))
        (eq? (unannotate i) (unannotate j)))))

;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
;;; as long as the missing portion of the wrap is common to all of the
;;; ids.

(define valid-bound-ids?
  (lambda (ids)
     (and (let all-ids? ((ids ids))
            (or (null? ids)
                (and (id? (car ids))
                     (all-ids? (cdr ids)))))
          (distinct-bound-ids? ids))))

;;; distinct-bound-ids? expects a list of ids and returns #t if there are
;;; no duplicates.  It is quadratic on the length of the id list; long
;;; lists could be sorted to make it more efficient.  distinct-bound-ids?
;;; may be passed unwrapped (or partially wrapped) ids as long as the
;;; missing portion of the wrap is common to all of the ids.

(define distinct-bound-ids?
  (lambda (ids)
    (let distinct? ((ids ids))
      (or (null? ids)
          (and (not (bound-id-member? (car ids) (cdr ids)))
               (distinct? (cdr ids)))))))

(define bound-id-member?
   (lambda (x list)
      (and (not (null? list))
           (or (bound-id=? x (car list))
               (bound-id-member? x (cdr list))))))

;;; wrapping expressions and identifiers

(define wrap
  (lambda (x w)
    (cond
      ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
      ((syntax-object? x)
       (make-syntax-object
         (syntax-object-expression x)
         (join-wraps w (syntax-object-wrap x))))
      ((null? x) x)
      (else (make-syntax-object x w)))))

(define source-wrap
  (lambda (x w s)
    (wrap (if s (make-annotation x s #f) x) w)))

;;; expanding

(define chi-sequence
  (lambda (body r w s)
    (build-sequence s
      (let dobody ((body body) (r r) (w w))
        (if (null? body)
            '()
            (let ((first (chi (car body) r w)))
              (cons first (dobody (cdr body) r w))))))))

(define chi-top-sequence
  (lambda (body r w s m esew)
    (build-sequence s
      (let dobody ((body body) (r r) (w w) (m m) (esew esew))
        (if (null? body)
            '()
            (let ((first (chi-top (car body) r w m esew)))
              (cons first (dobody (cdr body) r w m esew))))))))

(define chi-install-global
  (lambda (name e)
    (build-application no-source
      (build-primref no-source 'install-global-transformer)
      (list (build-data no-source name) e))))

(define chi-when-list
  (lambda (e when-list w)
    ; when-list is syntax'd version of list of situations
    (let f ((when-list when-list) (situations '()))
      (if (null? when-list)
          situations
          (f (cdr when-list)
             (cons (let ((x (car when-list)))
                     (cond
                       ((free-id=? x (syntax compile)) 'compile)
                       ((free-id=? x (syntax load)) 'load)
                       ((free-id=? x (syntax eval)) 'eval)
                       (else (syntax-error (wrap x w)
                               "invalid eval-when situation"))))
                   situations))))))

;;; syntax-type returns five values: type, value, e, w, and s.  The first
;;; two are described in the table below.
;;;
;;;    type                   value         explanation
;;;    -------------------------------------------------------------------
;;;    core                   procedure     core form (including singleton)
;;;    lexical                name          lexical variable reference
;;;    global                 name          global variable reference
;;;    begin                  none          begin keyword
;;;    define                 none          define keyword
;;;    define-syntax          none          define-syntax keyword
;;;    local-syntax           rec?          letrec-syntax/let-syntax keyword
;;;    eval-when              none          eval-when keyword
;;;    syntax                 level         pattern variable
;;;    displaced-lexical      none          displaced lexical identifier
;;;    lexical-call           name          call to lexical variable
;;;    global-call            name          call to global variable
;;;    call                   none          any other call
;;;    begin-form             none          begin expression
;;;    define-form            id            variable definition
;;;    define-syntax-form     id            syntax definition
;;;    local-syntax-form      rec?          syntax definition
;;;    eval-when-form         none          eval-when form
;;;    constant               none          self-evaluating datum
;;;    other                  none          anything else
;;;
;;; For define-form and define-syntax-form, e is the rhs expression.
;;; For all others, e is the entire form.  w is the wrap for e.
;;; s is the source for the entire form.
;;;
;;; syntax-type expands macros and unwraps as necessary to get to
;;; one of the forms above.  It also parses define and define-syntax
;;; forms, although perhaps this should be done by the consumer.

(define syntax-type
  (lambda (e r w s rib)
    (cond
      ((symbol? e)
       (let* ((n (id-var-name e w))
              (b (lookup n r))
              (type (binding-type b)))
         (case type
           ((lexical) (values type (binding-value b) e w s))
           ((global) (values type n e w s))
           ((macro)
            (syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib))
           (else (values type (binding-value b) e w s)))))
      ((pair? e)
       (let ((first (car e)))
         (if (id? first)
             (let* ((n (id-var-name first w))
                    (b (lookup n r))
                    (type (binding-type b)))
               (case type
                 ((lexical) (values 'lexical-call (binding-value b) e w s))
                 ((global) (values 'global-call n e w s))
                 ((macro)
                  (syntax-type (chi-macro (binding-value b) e r w rib)
                    r empty-wrap s rib))
                 ((core) (values type (binding-value b) e w s))
                 ((local-syntax)
                  (values 'local-syntax-form (binding-value b) e w s))
                 ((begin) (values 'begin-form #f e w s))
                 ((eval-when) (values 'eval-when-form #f e w s))
                 ((define)
                  (syntax-case e ()
                    ((_ name val)
                     (id? (syntax name))
                     (values 'define-form (syntax name) (syntax val) w s))
                    ((_ (name . args) e1 e2 ...)
                     (and (id? (syntax name))
                          (valid-bound-ids? (lambda-var-list (syntax args))))
                     ; need lambda here...
                     (values 'define-form (wrap (syntax name) w)
                       (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
                       empty-wrap s))
                    ((_ name)
                     (id? (syntax name))
                     (values 'define-form (wrap (syntax name) w)
                       (syntax (void))
                       empty-wrap s))))
                 ((define-syntax)
                  (syntax-case e ()
                    ((_ name val)
                     (id? (syntax name))
                     (values 'define-syntax-form (syntax name)
                       (syntax val) w s))))
                 (else (values 'call #f e w s))))
             (values 'call #f e w s))))
      ((syntax-object? e)
       ;; s can't be valid source if we've unwrapped
       (syntax-type (syntax-object-expression e)
                    r
                    (join-wraps w (syntax-object-wrap e))
                    no-source rib))
      ((annotation? e)
       (syntax-type (annotation-expression e) r w (annotation-source e) rib))