80 lines
2.6 KiB
Racket
80 lines
2.6 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/contract
|
|
compiler/zo-parse)
|
|
|
|
(define (prefix-syntax-start pre)
|
|
(length (prefix-toplevels pre)))
|
|
|
|
(define (prefix-lift-start pre)
|
|
(define syntax-start (prefix-syntax-start pre))
|
|
(define total-stxs (length (prefix-stxs pre)))
|
|
(+ syntax-start total-stxs (if (zero? total-stxs) 0 1)))
|
|
|
|
(struct nothing ())
|
|
|
|
(define-syntax-rule (eprintf* . args) (void))
|
|
|
|
(define (build-form-memo inner-update #:void? [void? #f])
|
|
(define memo (make-hasheq))
|
|
(define (update form . args)
|
|
(eprintf* "Updating on ~a\n" form)
|
|
(define fin
|
|
(cond
|
|
[(hash-ref memo form #f)
|
|
=> (λ (x)
|
|
(eprintf* "Found in memo table\n")
|
|
x)]
|
|
[else
|
|
(eprintf* "Not in memo table\n")
|
|
(let ()
|
|
(define ph (make-placeholder (nothing)))
|
|
(hash-set! memo form ph)
|
|
(define nv (nothing))
|
|
(dynamic-wind void
|
|
(λ ()
|
|
(set! nv (apply inner-update form args)))
|
|
(λ ()
|
|
(if (nothing? nv)
|
|
(eprintf* "inner-update returned nothing (or there was an escape) on ~a\n" form)
|
|
(begin
|
|
(placeholder-set! ph nv)
|
|
(hash-set! memo form nv)))))
|
|
nv)]))
|
|
(eprintf* "Updating on ~a ---->\n ~a\n" form fin)
|
|
fin)
|
|
(define (first-update form . args)
|
|
(eprintf* "Top level update on ~a\n" form)
|
|
(define final (apply update form args))
|
|
(eprintf* "Top level update on ~a ---->\n ~a\n" form final)
|
|
(define fin (make-reader-graph final))
|
|
(eprintf* "Top level update on ~a ---->\n ~a [after reader-graph]\n" form fin)
|
|
fin)
|
|
(values first-update update))
|
|
|
|
(define lang-info/c
|
|
(or/c #f (vector/c module-path? symbol? any/c)))
|
|
|
|
|
|
(define (build-compiled-path base name)
|
|
(build-path
|
|
(cond [(path? base) base]
|
|
[(eq? base 'relative) 'same]
|
|
[(eq? base #f) (error 'batch "Impossible")])
|
|
"compiled"
|
|
name))
|
|
|
|
|
|
(provide/contract
|
|
[prefix-syntax-start (prefix? . -> . exact-nonnegative-integer?)]
|
|
[prefix-lift-start (prefix? . -> . exact-nonnegative-integer?)]
|
|
[eprintf ((string?) () #:rest (listof any/c) . ->* . void)]
|
|
[build-form-memo
|
|
(((unconstrained-domain-> any/c))
|
|
(#:void? boolean?)
|
|
. ->* .
|
|
(values (unconstrained-domain-> any/c)
|
|
(unconstrained-domain-> any/c)))]
|
|
[lang-info/c contract?]
|
|
[build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))])
|