psyntax.ss

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

;;; hooks to nonportable run-time helpers
(begin
(define fx+ +)
(define fx- -)
(define fx= =)
(define fx< <)

(define annotation? (lambda (x) #f))

(define top-level-eval-hook
  (lambda (x)
    (eval `(,noexpand ,x) (interaction-environment))))

(define local-eval-hook
  (lambda (x)
    (eval `(,noexpand ,x) (interaction-environment))))

(define error-hook
  (lambda (who why what)
    (error who "~a ~s" why what)))

(define-syntax gensym-hook
  (syntax-rules ()
    ((_) (gensym))))

(define put-global-definition-hook
  (lambda (symbol binding)
     (putprop symbol '*sc-expander* binding)))

(define get-global-definition-hook
  (lambda (symbol)
     (getprop symbol '*sc-expander*)))
)


;;; output constructors
(begin
(define-syntax build-application
  (syntax-rules ()
    ((_ source fun-exp arg-exps)
     `(,fun-exp . ,arg-exps))))

(define-syntax build-conditional
  (syntax-rules ()
    ((_ source test-exp then-exp else-exp)
     `(if ,test-exp ,then-exp ,else-exp))))

(define-syntax build-lexical-reference
  (syntax-rules ()
    ((_ type source var)
     var)))

(define-syntax build-lexical-assignment
  (syntax-rules ()
    ((_ source var exp)
     `(set! ,var ,exp))))

(define-syntax build-global-reference
  (syntax-rules ()
    ((_ source var)
     var)))

(define-syntax build-global-assignment
  (syntax-rules ()
    ((_ source var exp)
     `(set! ,var ,exp))))

(define-syntax build-global-definition
  (syntax-rules ()
    ((_ source var exp)
     `(define ,var ,exp))))

(define-syntax build-lambda
  (syntax-rules ()
    ((_ src vars exp)
     `(lambda ,vars ,exp))))

(define-syntax build-primref
  (syntax-rules ()
    ((_ src name) name)
    ((_ src level name) name)))

(define-syntax build-data
  (syntax-rules ()
    ((_ src exp) `',exp)))

(define build-sequence
  (lambda (src exps)
    (if (null? (cdr exps))
        (car exps)
        `(begin ,@exps))))

(define build-let
  (lambda (src vars val-exps body-exp)
    (if (null? vars)
	body-exp
	`(let ,(map list vars val-exps) ,body-exp))))

(define build-named-let
  (lambda (src vars val-exps body-exp)
    (if (null? vars)
	body-exp
	`(let ,(car vars) ,(map list (cdr vars) val-exps) ,body-exp))))

(define build-letrec
  (lambda (src vars val-exps body-exp)
    (if (null? vars)
        body-exp
        `(letrec ,(map list vars val-exps) ,body-exp))))

(define-syntax build-lexical-var
  (syntax-rules ()
    ((_ src id) (gensym (symbol->string id)))))

(define-syntax self-evaluating?
  (syntax-rules ()
    ((_ e)
     (let ((x e))
       (or (boolean? x) (number? x) (string? x) (char? x) (null? x) (keyword? x))))))
)

(define-structure (syntax-object expression wrap))

(define-syntax unannotate
  (syntax-rules ()
    ((_ x)
     (let ((e x))
       (if (annotation? e)
           (annotation-expression e)
           e)))))

(define-syntax no-source (identifier-syntax #f))

(define source-annotation
  (lambda (x)
     (cond
       ((annotation? x) (annotation-source x))
       ((syntax-object? x) (source-annotation (syntax-object-expression x)))
       (else no-source))))

(define-syntax arg-check
  (syntax-rules ()
    ((_ pred? e who)
     (let ((x e))
       (if (not (pred? x)) (error-hook who "invalid argument" x))))))

;;; compile-time environments

;;; wrap and environment comprise two level mapping.
;;;   wrap : id --> label
;;;   env : label --> <element>

;;; environments are represented in two parts: a lexical part and a global
;;; part.  The lexical part is a simple list of associations from labels
;;; to bindings.  The global part is implemented by
;;; {put,get}-global-definition-hook and associates symbols with
;;; bindings.

;;; global (assumed global variable) and displaced-lexical (see below)
;;; do not show up in any environment; instead, they are fabricated by
;;; lookup when it finds no other bindings.

;;; <environment>              ::= ((<label> . <binding>)*)

;;; identifier bindings include a type and a value

;;; <binding> ::= (macro . <procedure>)           macros
;;;               (core . <procedure>)            core forms
;;;               (begin)                         begin
;;;               (define)                        define
;;;               (define-syntax)                 define-syntax
;;;               (local-syntax . rec?)           let-syntax/letrec-syntax
;;;               (eval-when)                     eval-when
;;;               (syntax . (<var> . <level>))    pattern variables
;;;               (global)                        assumed global variable
;;;               (lexical . <var>)               lexical variables
;;;               (displaced-lexical)             displaced lexicals
;;; <level>   ::= <nonnegative integer>
;;; <var>     ::= variable returned by build-lexical-var

;;; a macro is a user-defined syntactic-form.  a core is a system-defined
;;; syntactic form.  begin, define, define-syntax, and eval-when are
;;; treated specially since they are sensitive to whether the form is
;;; at top-level and (except for eval-when) can denote valid internal
;;; definitions.

;;; a pattern variable is a variable introduced by syntax-case and can
;;; be referenced only within a syntax form.

;;; any identifier for which no top-level syntax definition or local
;;; binding of any kind has been seen is assumed to be a global
;;; variable.

;;; a lexical variable is a lambda- or letrec-bound variable.

;;; a displaced-lexical identifier is a lexical identifier removed from
;;; it's scope by the return of a syntax object containing the identifier.
;;; a displaced lexical can also appear when a letrec-syntax-bound
;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
;;; a displaced lexical should never occur with properly written macros.

(define-syntax make-binding
  (syntax-rules (quote)
    ((_ type value) (cons type value))
    ((_ 'type) '(type))
    ((_ type) (cons type '()))))
(define binding-type car)
(define binding-value cdr)

(define-syntax null-env (identifier-syntax '()))

(define extend-env
  (lambda (labels bindings r) 
    (if (null? labels)
        r
        (extend-env (cdr labels) (cdr bindings)
          (cons (cons (car labels) (car bindings)) r)))))

(define extend-var-env
  ; variant of extend-env that forms "lexical" binding
  (lambda (labels vars r)
    (if (null? labels)
        r
        (extend-var-env (cdr labels) (cdr vars)
          (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))

;;; we use a "macros only" environment in expansion of local macro
;;; definitions so that their definitions can use local macros without
;;; attempting to use other lexical identifiers.
(define macros-only-env
  (lambda (r)
    (if (null? r)
        '()
        (let ((a (car r)))
          (if (eq? (cadr a) 'macro)
              (cons a (macros-only-env (cdr r)))
              (macros-only-env (cdr r)))))))

(define lookup
  ; x may be a label or a symbol
  ; although symbols are usually global, we check the environment first
  ; anyway because a temporary binding may have been established by
  ; fluid-let-syntax
  (lambda (x r)
    (cond
      ((assq x r) => cdr)
      ((symbol? x)
       (or (get-global-definition-hook x) (make-binding 'global)))
      (else (make-binding 'displaced-lexical)))))

(define global-extend
  (lambda (type sym val)
    (put-global-definition-hook sym (make-binding type val))))


;;; Conceptually, identifiers are always syntax objects.  Internally,
;;; however, the wrap is sometimes maintained separately (a source of
;;; efficiency and confusion), so that symbols are also considered
;;; identifiers by id?.  Externally, they are always wrapped.

(define nonsymbol-id?
  (lambda (x)
    (and (syntax-object? x)
         (symbol? (unannotate (syntax-object-expression x))))))

(define id?
  (lambda (x)
    (cond
      ((symbol? x) #t)
      ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
      ((annotation? x) (symbol? (annotation-expression x)))
      (else #f))))

(define-syntax id-sym-name
  (syntax-rules ()
    ((_ e)
     (let ((x e))
       (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))

(define id-sym-name&marks
  (lambda (x w)
    (if (syntax-object? x)
        (values
          (unannotate (syntax-object-expression x))
          (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
        (values (unannotate x) (wrap-marks w)))))

;;; syntax object wraps

;;;         <wrap> ::= ((<mark> ...) . (<subst> ...))
;;;        <subst> ::= <shift> | <subs>
;;;         <subs> ::= #(<old name> <label> (<mark> ...))
;;;        <shift> ::= positive fixnum

(define make-wrap cons)
(define wrap-marks car)
(define wrap-subst cdr)

(define-syntax subst-rename? (identifier-syntax vector?))
(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
(define-syntax make-rename
  (syntax-rules ()
    ((_ old new marks) (vector old new marks))))

;;; labels must be comparable with "eq?" and distinct from symbols.
(define gen-label
  (lambda () (string #\i)))

(define gen-labels
  (lambda (ls)
    (if (null? ls)
        '()
        (cons (gen-label) (gen-labels (cdr ls))))))

(define-structure (ribcage symnames marks labels))

(define-syntax empty-wrap (identifier-syntax '(())))

(define-syntax top-wrap (identifier-syntax '((top))))

(define-syntax top-marked?
  (syntax-rules ()
    ((_ w) (memq 'top (wrap-marks w)))))

;;; Marks must be comparable with "eq?" and distinct from pairs and
;;; the symbol top.  We do not use integers so that marks will remain
;;; unique even across file compiles.

(define-syntax the-anti-mark (identifier-syntax #f))

(define anti-mark
  (lambda (w)
    (make-wrap (cons the-anti-mark (wrap-marks w))
               (cons 'shift (wrap-subst w)))))