remove unused library (formerly used by the Racket->C compiler)
This commit is contained in:
Matthew Flatt
parent
13605b55db
commit
edec6fafd1
|
|
@ -11,5 +11,4 @@
|
|||
@include-section["free-vars.scrbl"]
|
||||
@include-section["strip-context.scrbl"]
|
||||
@include-section["keyword.scrbl"]
|
||||
@include-section["zodiac.scrbl"]
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +0,0 @@
|
|||
#lang scribble/doc
|
||||
@(require "common.rkt" (for-label syntax/zodiac))
|
||||
|
||||
@title[#:tag "zodiac"]{Legacy Zodiac Interface}
|
||||
|
||||
@defmodule*[(syntax/zodiac syntax/zodiac-unit syntax/zodiac-sig)]
|
||||
|
||||
The interface is similar to Zodiac---enough to be useful for
|
||||
porting---but different in many ways. See the source
|
||||
@filepath{zodiac-sig.rkt} for details. New software should not use this
|
||||
compatibility layer.
|
||||
|
|
@ -1,109 +0,0 @@
|
|||
|
||||
;; Interface for zodiac compatibility layer,
|
||||
;; for programs that used to manipulate the
|
||||
;; output of zodiac elaboration.
|
||||
|
||||
#lang scheme/signature
|
||||
|
||||
;; Syntax -> zodiac compatibility:
|
||||
syntax->zodiac
|
||||
;; Zodiac compatibility -> syntax:
|
||||
zodiac->syntax
|
||||
|
||||
structurize-syntax
|
||||
zread-object ; = (compose syntax-e zodiac-stx)
|
||||
|
||||
;; origin struct:
|
||||
origin-who ; 'source or 'macro
|
||||
origin-how ; #f or tree of syntax objects,
|
||||
; as repotred by the 'origin
|
||||
; property of the syntax object.
|
||||
|
||||
;; location struct:
|
||||
location-line ; = syntax line
|
||||
location-column ; = syntax col
|
||||
location-file ; = syntax src
|
||||
;; Note: there is no location-offset, yet
|
||||
|
||||
;; EOF
|
||||
eof?
|
||||
|
||||
;; zodiac struct:
|
||||
;; zodiac (stx) ; used to be (origin start finish)
|
||||
(struct zodiac (stx) #:mutable)
|
||||
zodiac-origin ; = identity
|
||||
zodiac-start ; = identity
|
||||
zodiac-finish ; = zodiac-start
|
||||
|
||||
;; reader structs:
|
||||
;; zodiac (stx)
|
||||
;; zread ; used to have (object)
|
||||
;; The sub-tree has been cut off; inspect
|
||||
;; the stx object, instead.
|
||||
(struct zread () #:mutable)
|
||||
|
||||
;; elaborator structs:
|
||||
(struct parsed (back) #:mutable)
|
||||
|
||||
(struct varref (var) #:mutable)
|
||||
(struct top-level-varref (module slot exptime? expdef? position) #:mutable) ; added module, exptime?, position
|
||||
create-top-level-varref
|
||||
(struct bound-varref (binding) #:mutable) create-bound-varref
|
||||
|
||||
(struct binding (var orig-name) #:mutable) create-binding
|
||||
|
||||
make-lexical-varref
|
||||
lexical-varref? create-lexical-varref ; alias for bound-varref
|
||||
make-lexical-binding
|
||||
lexical-binding? create-lexical-binding ; alias for binding
|
||||
|
||||
(struct app (fun args) #:mutable) create-app
|
||||
|
||||
(struct if-form (test then else) #:mutable) create-if-form
|
||||
(struct quote-form (expr) #:mutable) create-quote-form
|
||||
(struct begin-form (bodies) #:mutable) create-begin-form
|
||||
(struct begin0-form (bodies) #:mutable) create-begin0-form
|
||||
(struct let-values-form (vars vals body) #:mutable) create-let-values-form
|
||||
(struct letrec-values-form (vars vals body) #:mutable) create-letrec-values-form
|
||||
(struct define-values-form (vars val) #:mutable) create-define-values-form
|
||||
(struct set!-form (var val) #:mutable) create-set!-form
|
||||
(struct case-lambda-form (args bodies) #:mutable) create-case-lambda-form
|
||||
(struct with-continuation-mark-form (key val body) #:mutable) create-with-continuation-mark-form
|
||||
|
||||
;; Thess are new:
|
||||
(struct quote-syntax-form (expr) #:mutable) create-quote-syntax-form
|
||||
(struct define-syntaxes-form (names expr) #:mutable) create-define-syntaxes-form
|
||||
(struct define-for-syntax-form (names expr) #:mutable) create-define-for-syntax-form
|
||||
(struct module-form (name requires ; lstof stx for module paths
|
||||
for-syntax-requires ; lstof stx for module paths
|
||||
for-template-requires ; lstof stx for module paths
|
||||
body ; begin form
|
||||
syntax-body ; begin form
|
||||
provides ; lstof (sym | (def-sym . prvd-sym) #:mutable | (mod-path def-sym . prvd-sym))
|
||||
syntax-provides ; ditto
|
||||
indirect-provides ; lstof sym
|
||||
kernel-reprovide-hint ; #f | #t | exclude-sym
|
||||
self-path-index)) ; module path index
|
||||
create-module-form
|
||||
(struct require/provide-form () #:mutable) create-require/provide-form
|
||||
|
||||
;; These forms are highly mzc-specific. They are recongized
|
||||
;; as applications of the corresponding quoted symbols to the
|
||||
;; right kinds of arguments.
|
||||
(struct global-prepare (vec pos) #:mutable) create-global-prepare
|
||||
(struct global-lookup (vec pos) #:mutable) create-global-lookup
|
||||
(struct global-assign (vec pos expr) #:mutable) create-global-assign
|
||||
(struct safe-vector-ref (vec pos) #:mutable) create-safe-vector-ref
|
||||
global-prepare-id
|
||||
global-lookup-id
|
||||
global-assign-id
|
||||
safe-vector-ref-id
|
||||
|
||||
;; args:
|
||||
(struct arglist (vars) #:mutable)
|
||||
(struct sym-arglist () #:mutable)
|
||||
(struct list-arglist () #:mutable)
|
||||
(struct ilist-arglist () #:mutable)
|
||||
|
||||
make-empty-back-box
|
||||
register-client
|
||||
|
|
@ -1,758 +0,0 @@
|
|||
;; Zodiac compatibility layer,
|
||||
;; for programs that used to manipulate the
|
||||
;; output of zodiac elaboration.
|
||||
|
||||
#lang scheme/unit
|
||||
|
||||
(require "kerncase.rkt"
|
||||
"zodiac-sig.rkt"
|
||||
"stx.rkt")
|
||||
|
||||
(import)
|
||||
(export zodiac^)
|
||||
|
||||
(define (stx-bound-assq ssym l)
|
||||
(ormap (lambda (p)
|
||||
(and (bound-identifier=? ssym (car p))
|
||||
p))
|
||||
l))
|
||||
|
||||
(define global-prepare-id (gensym))
|
||||
(define global-lookup-id (gensym))
|
||||
(define global-assign-id (gensym))
|
||||
(define safe-vector-ref-id (gensym))
|
||||
|
||||
;; Back boxes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-struct secure-box (value) #:mutable)
|
||||
|
||||
(define init-value-list '())
|
||||
|
||||
(define register-initial-value
|
||||
(lambda (index value-thunk)
|
||||
(set! init-value-list
|
||||
(append init-value-list
|
||||
(list value-thunk)))))
|
||||
|
||||
(define make-initial-value-vector
|
||||
(lambda ()
|
||||
(let ((v (make-vector current-vector-size uninitialized-flag)))
|
||||
(let loop ((index 0) (inits init-value-list))
|
||||
(unless (null? inits)
|
||||
(vector-set! v index ((car inits)))
|
||||
(loop (add1 index) (cdr inits))))
|
||||
v)))
|
||||
|
||||
(define make-empty-back-box
|
||||
(lambda ()
|
||||
(make-secure-box (make-initial-value-vector))))
|
||||
|
||||
(define current-vector-size 2)
|
||||
|
||||
(define next-client-count
|
||||
(let ((count -1))
|
||||
(lambda ()
|
||||
(set! count (add1 count))
|
||||
(when (>= count current-vector-size)
|
||||
(set! current-vector-size (* 2 current-vector-size)))
|
||||
count)))
|
||||
|
||||
(define-struct uninitialized-back ())
|
||||
(define uninitialized-flag (make-uninitialized-back))
|
||||
|
||||
(define getters-setters
|
||||
(lambda (index)
|
||||
(values
|
||||
(lambda (back) ; getter
|
||||
(let ((v (secure-box-value back)))
|
||||
(with-handlers
|
||||
((exn:fail:contract?
|
||||
(lambda (exception)
|
||||
(vector-ref (extend-back-vector back) index))))
|
||||
(let ((value (vector-ref v index)))
|
||||
(if (uninitialized-back? value)
|
||||
(let ((correct-value
|
||||
((list-ref init-value-list index))))
|
||||
(vector-set! v index correct-value)
|
||||
correct-value)
|
||||
value)))))
|
||||
(lambda (back value) ; setter
|
||||
(let ((v (secure-box-value back)))
|
||||
(with-handlers
|
||||
((exn:fail:contract?
|
||||
(lambda (exception)
|
||||
(vector-set! (extend-back-vector back) index value))))
|
||||
(vector-set! v index value)))))))
|
||||
|
||||
(define register-client
|
||||
(lambda (client-name default-initial-value-thunk)
|
||||
(let ((index (next-client-count)))
|
||||
(register-initial-value index default-initial-value-thunk)
|
||||
(getters-setters index))))
|
||||
|
||||
(define extend-back-vector
|
||||
(lambda (back-box)
|
||||
(let ((v (secure-box-value back-box)))
|
||||
(let ((new-v (make-initial-value-vector)))
|
||||
(let loop ((n (sub1 (vector-length v))))
|
||||
(when (>= n 0)
|
||||
(vector-set! new-v n (vector-ref v n))
|
||||
(loop (sub1 n))))
|
||||
(set-secure-box-value! back-box new-v)
|
||||
new-v))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (mk-back) (make-empty-back-box))
|
||||
|
||||
(define (get-slot stx table)
|
||||
(let ([l (hash-ref table (syntax-e stx) (lambda () null))])
|
||||
(let ([s (ormap (lambda (b)
|
||||
(and (free-identifier=? stx (car b))
|
||||
(cdr b)))
|
||||
l)])
|
||||
(if s
|
||||
s
|
||||
(let ([s (box #f)])
|
||||
(hash-set! table (syntax-e stx) (cons (cons stx s) l))
|
||||
s)))))
|
||||
|
||||
(define (let-s->z mk-let rec? stx env loop)
|
||||
(syntax-case stx ()
|
||||
[(_ ([vars rhs] ...) . body)
|
||||
(let* ([varses (syntax->list (syntax (vars ...)))]
|
||||
[rhses (syntax->list (syntax (rhs ...)))]
|
||||
[z:varses (map (lambda (vars)
|
||||
(map (lambda (var)
|
||||
(make-binding
|
||||
stx
|
||||
(mk-back)
|
||||
(gensym (syntax-e var))
|
||||
(syntax-e var)))
|
||||
(syntax->list vars)))
|
||||
varses)]
|
||||
[body-env (append
|
||||
(apply
|
||||
append
|
||||
(map (lambda (z:vars vars)
|
||||
(map (lambda (z:var var)
|
||||
(cons
|
||||
var
|
||||
z:var))
|
||||
z:vars
|
||||
(syntax->list vars)))
|
||||
z:varses
|
||||
varses))
|
||||
env)])
|
||||
(mk-let
|
||||
stx
|
||||
(mk-back)
|
||||
z:varses
|
||||
(map (lambda (rhs)
|
||||
(loop rhs (if rec? body-env env)))
|
||||
rhses)
|
||||
(loop (syntax (begin . body)) body-env)))]))
|
||||
|
||||
(define (args-s->z env args)
|
||||
(let-values ([(maker ids)
|
||||
(syntax-case args ()
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(values make-sym-arglist
|
||||
(list (syntax id)))]
|
||||
[(id ...)
|
||||
(values make-list-arglist (syntax->list args))]
|
||||
[_else (values make-ilist-arglist
|
||||
(let loop ([args args])
|
||||
(syntax-case args ()
|
||||
[id (identifier? args) (list args)]
|
||||
[(id . rest)
|
||||
(cons (syntax id) (loop (syntax rest)))])))])])
|
||||
(let ([bindings
|
||||
(map (lambda (id)
|
||||
(make-binding
|
||||
id
|
||||
(mk-back)
|
||||
(gensym (syntax-e id))
|
||||
(syntax-e id)))
|
||||
ids)])
|
||||
(values
|
||||
(append (map cons ids bindings) env)
|
||||
(maker bindings)))))
|
||||
|
||||
(define (syntax->zodiac stx)
|
||||
(define slot-table (make-hasheq))
|
||||
(define trans-slot-table (make-hasheq))
|
||||
(define syntax-slot-table (make-hasheq))
|
||||
|
||||
(if (eof-object? stx)
|
||||
stx
|
||||
(let loop ([stx stx][env null][trans? #f])
|
||||
(kernel-syntax-case stx trans?
|
||||
[id
|
||||
(identifier? stx)
|
||||
(let ([a (stx-bound-assq stx env)])
|
||||
(if a
|
||||
;; Lexical reference:
|
||||
(make-bound-varref
|
||||
stx
|
||||
(mk-back)
|
||||
(binding-var (cdr a))
|
||||
(cdr a))
|
||||
;; Top-level (or module) reference:
|
||||
(let ([b (let ([b ((if trans?
|
||||
identifier-transformer-binding
|
||||
identifier-binding)
|
||||
stx)])
|
||||
;; If b, is it imported?
|
||||
(and (pair? b)
|
||||
(let ([modname (and (pair? b) (car b))])
|
||||
(and (or (symbol? modname)
|
||||
(and (module-path-index? modname)
|
||||
(let-values ([(name base) (module-path-index-split modname)])
|
||||
(or name base))))
|
||||
b))))])
|
||||
(make-top-level-varref
|
||||
stx
|
||||
(mk-back)
|
||||
(if b
|
||||
(cadr b)
|
||||
(syntax-e stx))
|
||||
(let ([modname (and b (car b))])
|
||||
modname)
|
||||
(get-slot stx (if trans? trans-slot-table slot-table))
|
||||
trans?
|
||||
(and b (list-ref b 4))
|
||||
#f))))]
|
||||
|
||||
[(#%top . id)
|
||||
;; Top-level reference:
|
||||
(make-top-level-varref
|
||||
stx
|
||||
(mk-back)
|
||||
(syntax-e (syntax id))
|
||||
#f
|
||||
(get-slot (syntax id) (if trans? trans-slot-table slot-table))
|
||||
trans?
|
||||
#f
|
||||
#f)]
|
||||
|
||||
[(define-values names rhs)
|
||||
(make-define-values-form
|
||||
stx
|
||||
(mk-back)
|
||||
(map (lambda (stx)
|
||||
(let ([b (identifier-binding stx)])
|
||||
(make-top-level-varref
|
||||
stx
|
||||
(mk-back)
|
||||
(if (pair? b)
|
||||
(cadr b)
|
||||
(syntax-e stx))
|
||||
(and (pair? b) (car b))
|
||||
(get-slot stx slot-table)
|
||||
#f
|
||||
#f
|
||||
#f)))
|
||||
(syntax->list (syntax names)))
|
||||
(loop (syntax rhs) null #f))]
|
||||
|
||||
[(-define names rhs)
|
||||
(or (free-identifier=? #'-define #'define-syntaxes)
|
||||
(free-identifier=? #'-define #'define-values-for-syntax))
|
||||
(let ([for-stx? (free-identifier=? #'-define #'define-values-for-syntax)])
|
||||
((if for-stx?
|
||||
make-define-for-syntax-form
|
||||
make-define-syntaxes-form)
|
||||
stx
|
||||
(mk-back)
|
||||
(map (lambda (stx)
|
||||
(let ([b (identifier-binding stx)])
|
||||
(make-top-level-varref
|
||||
stx
|
||||
(mk-back)
|
||||
(if (pair? b)
|
||||
(cadr b)
|
||||
(syntax-e stx))
|
||||
(and (pair? b) (car b))
|
||||
(get-slot stx syntax-slot-table)
|
||||
#f
|
||||
for-stx?
|
||||
#f)))
|
||||
(syntax->list (syntax names)))
|
||||
(loop (syntax rhs) null #t)))]
|
||||
|
||||
[(module name init-require (#%plain-module-begin . body))
|
||||
(let* ([body (map (lambda (x)
|
||||
(loop x env trans?))
|
||||
(syntax->list (syntax body)))]
|
||||
[get-required-modules
|
||||
(lambda (req)
|
||||
(let loop ([body body])
|
||||
(cond
|
||||
[(null? body) null]
|
||||
[(and (require/provide-form? (car body))
|
||||
(free-identifier=? req (stx-car (zodiac-stx (car body)))))
|
||||
(append
|
||||
(map (lambda (r)
|
||||
(syntax-case* r (prefix all-except rename)
|
||||
(lambda (a b) (eq? (syntax-e a)
|
||||
(syntax-e b)))
|
||||
[mod
|
||||
(identifier? r)
|
||||
r]
|
||||
[(prefix id mod)
|
||||
(syntax mod)]
|
||||
[(rename mod . _)
|
||||
(syntax mod)]
|
||||
[(all-except mod . _)
|
||||
(syntax mod)]
|
||||
[_else r]))
|
||||
(stx->list (stx-cdr (zodiac-stx (car body)))))
|
||||
(loop (cdr body)))]
|
||||
[else (loop (cdr body))])))]
|
||||
[rt-required
|
||||
(cons (syntax init-require)
|
||||
(get-required-modules (quote-syntax require)))]
|
||||
[et-required
|
||||
(cons (syntax init-require)
|
||||
(get-required-modules (quote-syntax require-for-syntax)))]
|
||||
[tt-required
|
||||
(cons (syntax init-require)
|
||||
(get-required-modules (quote-syntax require-for-template)))]
|
||||
[et-body
|
||||
(filter (lambda (e)
|
||||
(or (define-syntaxes-form? e)
|
||||
(define-for-syntax-form? e)))
|
||||
body)]
|
||||
[rt-body
|
||||
(filter (lambda (e) (and (not (define-syntaxes-form? e))
|
||||
(not (define-for-syntax-form? e))
|
||||
(not (require/provide-form? e))))
|
||||
body)])
|
||||
(make-module-form
|
||||
stx
|
||||
(mk-back)
|
||||
(syntax name)
|
||||
rt-required
|
||||
et-required
|
||||
tt-required
|
||||
(make-begin-form
|
||||
stx
|
||||
(mk-back)
|
||||
rt-body)
|
||||
(make-begin-form
|
||||
stx
|
||||
(mk-back)
|
||||
et-body)
|
||||
(syntax-property stx 'module-variable-provides)
|
||||
(syntax-property stx 'module-syntax-provides)
|
||||
(syntax-property stx 'module-indirect-provides)
|
||||
(syntax-property stx 'module-kernel-reprovide-hint)
|
||||
(syntax-property stx 'module-self-path-index)))]
|
||||
[(#%require i ...)
|
||||
(make-require/provide-form
|
||||
stx
|
||||
(mk-back))]
|
||||
[(#%provide i ...)
|
||||
(make-require/provide-form
|
||||
stx
|
||||
(mk-back))]
|
||||
|
||||
[(quote expr)
|
||||
(make-quote-form
|
||||
stx
|
||||
(mk-back)
|
||||
(make-zread (syntax expr)))]
|
||||
|
||||
[(quote-syntax expr)
|
||||
(make-quote-syntax-form
|
||||
stx
|
||||
(mk-back)
|
||||
(syntax expr))]
|
||||
|
||||
[(#%plain-lambda args . body)
|
||||
(let-values ([(env args) (args-s->z env (syntax args))])
|
||||
(make-case-lambda-form
|
||||
stx
|
||||
(mk-back)
|
||||
(list args)
|
||||
(list (loop (syntax (begin . body)) env trans?))))]
|
||||
[(case-lambda [args . body] ...)
|
||||
(let-values ([(envs argses)
|
||||
(let ([es+as
|
||||
(map
|
||||
(lambda (args)
|
||||
(let-values ([(env args) (args-s->z env args)])
|
||||
(cons env args)))
|
||||
(syntax->list (syntax (args ...))))])
|
||||
(values
|
||||
(map car es+as)
|
||||
(map cdr es+as)))])
|
||||
(make-case-lambda-form
|
||||
stx
|
||||
(mk-back)
|
||||
argses
|
||||
(map (lambda (env body)
|
||||
(with-syntax ([body body])
|
||||
(loop (syntax (begin . body)) env trans?)))
|
||||
envs
|
||||
(syntax->list (syntax (body ...))))))]
|
||||
|
||||
[(let-values . _)
|
||||
(let-s->z make-let-values-form #f stx env
|
||||
(lambda (b env) (loop b env trans?)))]
|
||||
[(letrec-values . _)
|
||||
(let-s->z make-letrec-values-form #t stx env
|
||||
(lambda (b env) (loop b env trans?)))]
|
||||
|
||||
[(set! var rhs)
|
||||
(make-set!-form
|
||||
stx
|
||||
(mk-back)
|
||||
(loop (syntax var) env trans?)
|
||||
(loop (syntax rhs) env trans?))]
|
||||
|
||||
[(begin . exprs)
|
||||
(make-begin-form
|
||||
stx
|
||||
(mk-back)
|
||||
(map (lambda (x)
|
||||
(loop x env trans?))
|
||||
(syntax->list (syntax exprs))))]
|
||||
|
||||
[(begin0 . exprs)
|
||||
(make-begin0-form
|
||||
stx
|
||||
(mk-back)
|
||||
(map (lambda (x)
|
||||
(loop x env trans?))
|
||||
(syntax->list (syntax exprs))))]
|
||||
|
||||
[(if test then else)
|
||||
(make-if-form
|
||||
stx
|
||||
(mk-back)
|
||||
(loop (syntax test) env trans?)
|
||||
(loop (syntax then) env trans?)
|
||||
(loop (syntax else) env trans?))]
|
||||
|
||||
[(with-continuation-mark k v body)
|
||||
(make-with-continuation-mark-form
|
||||
stx
|
||||
(mk-back)
|
||||
(loop (syntax k) env trans?)
|
||||
(loop (syntax v) env trans?)
|
||||
(loop (syntax body) env trans?))]
|
||||
|
||||
[(#%plain-app 'gp vec (quote pos))
|
||||
(and (eq? (syntax-e #'gp) global-prepare-id)
|
||||
(number? (syntax-e #'pos)))
|
||||
(make-global-prepare
|
||||
stx
|
||||
(mk-back)
|
||||
(loop (syntax vec) env trans?)
|
||||
(syntax-e #'pos))]
|
||||
[(#%plain-app 'gl vec (quote pos))
|
||||
(and (eq? (syntax-e #'gl) global-lookup-id)
|
||||
(number? (syntax-e #'pos)))
|
||||
(make-global-lookup
|
||||
stx
|
||||
(mk-back)
|
||||
(loop (syntax vec) env trans?)
|
||||
(syntax-e #'pos))]
|
||||
[(#%plain-app 'ga vec (quote pos) val)
|
||||
(and (eq? (syntax-e #'ga) global-assign-id)
|
||||
(number? (syntax-e #'pos)))
|
||||
(make-global-assign
|
||||
stx
|
||||
(mk-back)
|
||||
(loop (syntax vec) env trans?)
|
||||
(syntax-e #'pos)
|
||||
(loop (syntax val) env trans?))]
|
||||
[(#%plain-app 'svr vec (quote pos))
|
||||
(and (eq? (syntax-e #'svr) safe-vector-ref-id)
|
||||
(number? (syntax-e #'pos)))
|
||||
(make-safe-vector-ref
|
||||
stx
|
||||
(mk-back)
|
||||
(loop (syntax vec) env trans?)
|
||||
(syntax-e #'pos))]
|
||||
|
||||
[(#%plain-app)
|
||||
(make-quote-form
|
||||
(syntax/loc stx ())
|
||||
(mk-back)
|
||||
(make-zread (quote-syntax ())))]
|
||||
[(#%plain-app func arg ...)
|
||||
(make-app
|
||||
stx
|
||||
(mk-back)
|
||||
(loop (syntax func) env trans?)
|
||||
(map
|
||||
(lambda (arg)
|
||||
(loop arg env trans?))
|
||||
(syntax->list (syntax (arg ...)))))]
|
||||
|
||||
[(#%expression e)
|
||||
(loop (syntax e) env trans?)]
|
||||
|
||||
[_else
|
||||
(error 'syntax->zodiac
|
||||
"unrecognized expression form: ~.s"
|
||||
(syntax->datum stx))]))))
|
||||
|
||||
|
||||
(define (zodiac->syntax x)
|
||||
(let loop ([x x])
|
||||
(cond
|
||||
[(zread? x)
|
||||
(zodiac-stx x)]
|
||||
|
||||
[(top-level-varref? x)
|
||||
(zodiac-stx x)]
|
||||
[(bound-varref? x)
|
||||
;; An stx object is getting gensymmed here!
|
||||
(datum->syntax #f (binding-var (bound-varref-binding x)) #f)]
|
||||
|
||||
[(app? x)
|
||||
(with-syntax ([fun (loop (app-fun x))]
|
||||
[args (map loop (app-args x))])
|
||||
(syntax (#%plain-app fun . args)))]
|
||||
|
||||
[(if-form? x)
|
||||
(with-syntax ([test (loop (if-form-test x))]
|
||||
[then (loop (if-form-then x))]
|
||||
[else (loop (if-form-else x))])
|
||||
(syntax (if test then else)))]
|
||||
|
||||
[(quote-form? x)
|
||||
(with-syntax ([v (zodiac-stx (quote-form-expr x))])
|
||||
(syntax (quote v)))]
|
||||
[(quote-syntax-form? x)
|
||||
(with-syntax ([v (quote-syntax-form-expr x)])
|
||||
(syntax (quote-syntax v)))]
|
||||
|
||||
[(begin-form? x)
|
||||
(with-syntax ([body (map loop (begin-form-bodies))])
|
||||
(syntax (begin . body)))]
|
||||
[(begin0-form? x)
|
||||
(with-syntax ([body (map loop (begin-form-bodies))])
|
||||
(syntax (begin0 . body)))]
|
||||
|
||||
[(let-values-form? x)
|
||||
(with-syntax ([(vars ...)
|
||||
(map (lambda (vars)
|
||||
(map binding-var vars))
|
||||
(let-values-form-vars x))]
|
||||
[(val ...)
|
||||
(map loop (let-values-form-vals x))]
|
||||
[body (loop (let-values-form-body x))])
|
||||
(syntax (let-values ([vars val] ...) body)))]
|
||||
[(letrec-values-form? x)
|
||||
(with-syntax ([(vars ...)
|
||||
(map (lambda (vars)
|
||||
(map binding-var vars))
|
||||
(letrec-values-form-vars x))]
|
||||
[(val ...)
|
||||
(map loop (letrec-values-form-vals x))]
|
||||
[body (loop (letrec-values-form-body x))])
|
||||
(syntax (letrec-values ([vars val] ...) body)))]
|
||||
|
||||
[(define-values-form? x)
|
||||
(with-syntax ([vars (map zodiac-stx (define-values-form-vars x))]
|
||||
[val (loop (define-values-form-val x))])
|
||||
(syntax (define-values vars val)))]
|
||||
|
||||
[(set!-form? x)
|
||||
(with-syntax ([var (loop (set!-form-var x))]
|
||||
[val (loop (set!-form-val x))])
|
||||
(syntax (set! var val)))]
|
||||
|
||||
[(case-lambda-form? x)
|
||||
(with-syntax ([(args ...)
|
||||
(map (lambda (args)
|
||||
(cond
|
||||
[(sym-arglist? args)
|
||||
(datum->syntax #f (binding-var (car (arglist-vars args))) #f)]
|
||||
[(list-arglist? args)
|
||||
(map (lambda (var)
|
||||
(datum->syntax #f (binding-var var) #f))
|
||||
(arglist-vars args))]
|
||||
[(ilist-arglist? args)
|
||||
(let loop ([vars (arglist-vars args)])
|
||||
(let ([id (datum->syntax #f (binding-var (car vars)) #f)])
|
||||
(if (null? (cdr vars))
|
||||
id
|
||||
(cons id (loop (cdr vars))))))]))
|
||||
(case-lambda-form-args x))]
|
||||
[(body ...)
|
||||
(map loop (case-lambda-form-bodies x))])
|
||||
(syntax (case-lambda [args body] ...)))]
|
||||
|
||||
[(with-continuation-mark-form? x)
|
||||
(with-syntax ([key (loop (with-continuation-mark-form-key x))]
|
||||
[val (loop (with-continuation-mark-form-val x))]
|
||||
[body (loop (with-continuation-mark-form-body x))])
|
||||
(syntax (with-continuation-mark key val body)))]
|
||||
|
||||
[else (error 'zodiac->syntax
|
||||
"unknown zodiac record type: ~e"
|
||||
x)])))
|
||||
|
||||
(define (zodiac-origin z) z)
|
||||
|
||||
(define (origin-who z)
|
||||
(if (syntax-original? (zodiac-stx z))
|
||||
'source
|
||||
'macro))
|
||||
|
||||
(define (origin-how z)
|
||||
(syntax-property (zodiac-stx z) 'origin))
|
||||
|
||||
(define (zodiac-start z) z)
|
||||
(define (zodiac-finish z) z)
|
||||
|
||||
(define (location-line z)
|
||||
(and (zodiac-stx z) (syntax-line (zodiac-stx z))))
|
||||
|
||||
(define (location-column z)
|
||||
(and (zodiac-stx z) (syntax-column (zodiac-stx z))))
|
||||
|
||||
(define (location-file z)
|
||||
(and (zodiac-stx z) (syntax-source (zodiac-stx z))))
|
||||
|
||||
(define (zread-object z)
|
||||
(syntax-e (zodiac-stx z)))
|
||||
|
||||
(define (structurize-syntax sexp)
|
||||
(make-zread (datum->syntax #f sexp #f)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define eof? eof-object?)
|
||||
|
||||
(define-struct zodiac (stx) #:mutable)
|
||||
(define-struct (zread zodiac) () #:mutable)
|
||||
|
||||
(define-struct (parsed zodiac) (back) #:mutable)
|
||||
|
||||
(define-struct (varref parsed) (var) #:mutable)
|
||||
|
||||
(define-struct (top-level-varref varref) (module slot exptime? expdef? position) #:mutable)
|
||||
(define (create-top-level-varref z var module slot exptime? expdef? position)
|
||||
(make-top-level-varref (zodiac-stx z) (mk-back) var module slot exptime? expdef? position))
|
||||
|
||||
(define-struct (bound-varref varref) (binding) #:mutable)
|
||||
(define (create-bound-varref z var binding)
|
||||
(make-bound-varref (zodiac-stx z) (mk-back) var binding))
|
||||
|
||||
(define lexical-varref? bound-varref?)
|
||||
(define make-lexical-varref make-bound-varref)
|
||||
(define create-lexical-varref create-bound-varref)
|
||||
|
||||
(define-struct (binding parsed) (var orig-name) #:mutable)
|
||||
(define (create-binding z var orig-name)
|
||||
(make-binding (zodiac-stx z) (mk-back) var orig-name))
|
||||
|
||||
(define lexical-binding? binding?)
|
||||
(define make-lexical-binding make-binding)
|
||||
(define create-lexical-binding create-binding)
|
||||
|
||||
|
||||
(define-struct (app parsed) (fun args) #:mutable)
|
||||
(define (create-app z fun args)
|
||||
(make-app (zodiac-stx z) (mk-back) fun args))
|
||||
|
||||
(define-struct (if-form parsed) (test then else) #:mutable)
|
||||
(define (create-if-form z test then else)
|
||||
(make-if-form (zodiac-stx z) (mk-back) test then else))
|
||||
|
||||
(define-struct (quote-form parsed) (expr) #:mutable)
|
||||
(define (create-quote-form z expr)
|
||||
(make-quote-form (zodiac-stx z) (mk-back) expr))
|
||||
|
||||
(define-struct (begin-form parsed) (bodies) #:mutable)
|
||||
(define (create-begin-form z bodies)
|
||||
(make-begin-form (zodiac-stx z) (mk-back) bodies))
|
||||
|
||||
(define-struct (begin0-form parsed) (bodies) #:mutable)
|
||||
(define (create-begin0-form z bodies)
|
||||
(make-begin0-form (zodiac-stx z) (mk-back) bodies))
|
||||
|
||||
(define-struct (let-values-form parsed) (vars vals body) #:mutable)
|
||||
(define (create-let-values-form z vars vals body)
|
||||
(make-let-values-form (zodiac-stx z) (mk-back) vars vals body))
|
||||
|
||||
(define-struct (letrec-values-form parsed) (vars vals body) #:mutable)
|
||||
(define (create-letrec-values-form z vars vals body)
|
||||
(make-letrec-values-form (zodiac-stx z) (mk-back) vars vals body))
|
||||
|
||||
(define-struct (define-values-form parsed) (vars val) #:mutable)
|
||||
(define (create-define-values-form z vars val)
|
||||
(make-define-values-form (zodiac-stx z) (mk-back) vars val))
|
||||
|
||||
(define-struct (set!-form parsed) (var val) #:mutable)
|
||||
(define (create-set!-form z var val)
|
||||
(make-set!-form (zodiac-stx z) (mk-back) var val))
|
||||
|
||||
(define-struct (case-lambda-form parsed) (args bodies) #:mutable)
|
||||
(define (create-case-lambda-form z args bodies)
|
||||
(make-case-lambda-form (zodiac-stx z) (mk-back) args bodies))
|
||||
|
||||
(define-struct (with-continuation-mark-form parsed) (key val body) #:mutable)
|
||||
(define (create-with-continuation-mark-form z key val body)
|
||||
(make-with-continuation-mark-form (zodiac-stx z) (mk-back) key val body))
|
||||
|
||||
(define-struct (quote-syntax-form parsed) (expr) #:mutable)
|
||||
(define (create-quote-syntax-form z expr)
|
||||
(make-quote-syntax-form (zodiac-stx z) (mk-back) expr))
|
||||
|
||||
(define-struct (define-syntaxes-form parsed) (names expr) #:mutable)
|
||||
(define (create-define-syntaxes-form z names expr)
|
||||
(make-define-syntaxes-form (zodiac-stx z) (mk-back) names expr))
|
||||
|
||||
(define-struct (define-for-syntax-form parsed) (names expr) #:mutable)
|
||||
(define (create-define-for-syntax-form z names expr)
|
||||
(make-define-for-syntax-form (zodiac-stx z) (mk-back) names expr))
|
||||
|
||||
(define-struct (module-form parsed) (name requires for-syntax-requires for-template-requires
|
||||
body syntax-body
|
||||
provides syntax-provides indirect-provides
|
||||
kernel-reprovide-hint
|
||||
self-path-index)
|
||||
#:mutable)
|
||||
(define (create-module-form z name rt-requires et-requires tt-requires
|
||||
rt-body et-body
|
||||
var-provides syntax-provides indirect-provides
|
||||
kernel-hint self)
|
||||
(make-module-form (zodiac-stx z) (mk-back)
|
||||
name rt-requires et-requires tt-requires
|
||||
rt-body et-body
|
||||
var-provides syntax-provides indirect-provides
|
||||
kernel-hint self))
|
||||
|
||||
(define-struct (require/provide-form parsed) ())
|
||||
(define (create-require/provide-form z)
|
||||
(make-require/provide-form (zodiac-stx z) (mk-back)))
|
||||
|
||||
(define-struct (global-prepare parsed) (vec pos) #:mutable)
|
||||
(define (create-global-prepare z vec pos)
|
||||
(make-global-prepare (zodiac-stx z) (mk-back) vec pos))
|
||||
|
||||
(define-struct (global-lookup parsed) (vec pos) #:mutable)
|
||||
(define (create-global-lookup z vec pos)
|
||||
(make-global-lookup (zodiac-stx z) (mk-back) vec pos))
|
||||
|
||||
(define-struct (global-assign parsed) (vec pos expr) #:mutable)
|
||||
(define (create-global-assign z vec pos expr)
|
||||
(make-global-assign (zodiac-stx z) (mk-back) vec pos expr))
|
||||
|
||||
(define-struct (safe-vector-ref parsed) (vec pos) #:mutable)
|
||||
(define (create-safe-vector-ref z vec pos)
|
||||
(make-safe-vector-ref (zodiac-stx z) (mk-back) vec pos))
|
||||
|
||||
(define-struct arglist (vars) #:mutable)
|
||||
(define-struct (sym-arglist arglist) () #:mutable)
|
||||
(define-struct (list-arglist arglist) () #:mutable)
|
||||
(define-struct (ilist-arglist arglist) () #:mutable)
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
(module zodiac mzscheme
|
||||
(require mzlib/unit)
|
||||
|
||||
(require "zodiac-sig.rkt"
|
||||
"zodiac-unit.rkt")
|
||||
|
||||
(define-values/invoke-unit/infer zodiac@)
|
||||
|
||||
(provide-signature-elements zodiac^))
|
||||
Loading…
Reference in New Issue
Block a user