suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Rackety (mostly letrec-values => define and minimizing dependencies)

Browse Source
This commit is contained in:
Robby Findler 2011-10-31 09:08:31 -05:00
parent 64dfdb3c7f
commit 0ce6c75591
5 changed files with 232 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/redex/private/dot.rkt
View File

@ -1,10 +1,11 @@
#lang scheme/gui
#lang racket/base
(require racket/contract
racket/class
racket/gui/base
racket/system)
(provide/contract [dot-positioning (-> (is-a?/c pasteboard%) string? boolean? void?)]
[find-dot (-> (or/c path? false/c))])
(require scheme/system)
(provide dot-label neato-label neato-hier-label neato-ipsep-label)
(define dot-label "dot")
(define neato-label "neato")

5
collects/redex/private/fresh.rkt
View File

@ -1,4 +1,5 @@
#lang scheme
#lang racket/base
(require racket/contract)
(define re:gen-d #rx".*[^0-9]([0-9]+)$")
(define (variable-not-in sexp var)
@ -31,7 +32,7 @@
(let loop ([sorted (sort nums <)]
[i 1])
(cond
[(empty? sorted) i]
[(null? sorted) i]
[else
(let ([fst (car sorted)])
(cond

5
collects/redex/private/keyword-macros.rkt
View File

@ -1,6 +1,7 @@
#lang racket
#lang racket/base
(require (for-template racket/base racket/contract))
(require racket/match
(for-template racket/base racket/contract))
(define (parse-kw-args formals actuals source form-name)
(let loop ([current (for/hash ([arg formals]) (values (car arg) #f))]

89
collects/redex/private/rg.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require "matcher.rkt"
"reduction-semantics.rkt"
@ -6,18 +6,17 @@
"term.rkt"
"error.rkt"
"struct.rkt"
(for-syntax scheme/base
(for-syntax racket/base
"rewrite-side-conditions.rkt"
"term-fn.rkt"
"reduction-semantics.rkt"
"keyword-macros.rkt")
scheme/dict
scheme/contract
scheme/promise
scheme/unit
scheme/match
scheme/pretty
scheme/function
racket/dict
racket/contract
racket/promise
racket/unit
racket/match
racket/pretty
mrlib/tex-table)
(define redex-pseudo-random-generator
@ -174,29 +173,27 @@
(import) (export decisions^))
(define (gen-nt lang name cross? retries size attempt filler)
(let*-values
([(productions)
(hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name)]
[(term _)
(define productions
(hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name))
(define-values (term _)
(let ([gen (pick-from-list
(if (zero? size)
(min-prods name productions
((if cross? base-cases-cross base-cases-non-cross)
(rg-lang-base-cases lang)))
((next-non-terminal-decision) productions)))])
(gen retries (max 0 (sub1 size)) attempt empty-env filler))])
term))
(gen retries (max 0 (sub1 size)) attempt empty-env filler)))
term)
(define (generate/pred name gen pred init-sz init-att retries)
(let ([pre-threshold-incr
(define pre-threshold-incr
(ceiling
(/ (- retry-threshold init-att)
(* proportion-before-threshold (add1 retries))))]
[incr-size?
(λ (remain)
(* proportion-before-threshold (add1 retries)))))
(define (incr-size? remain)
(zero?
(modulo (sub1 remain)
(ceiling (* proportion-at-size retries)))))])
(ceiling (* proportion-at-size retries)))))
(let retry ([remaining (add1 retries)]
[size init-sz]
[attempt init-att])
@ -210,7 +207,7 @@
(+ attempt
(if (>= attempt retry-threshold)
post-threshold-incr
pre-threshold-incr)))))))))
pre-threshold-incr))))))))
(define (generate/prior name env gen)
(let* ([none (gensym)]
@ -232,22 +229,21 @@
(foldl (λ (var env)
(hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs)))
env vars))
(let-values
([(seq envs)
(define-values (seq envs)
(let recur ([envs (split-environment env)])
(if (null? envs)
(values null null)
(let*-values
([(hd env) (gen (car envs))]
[(tl envs) (recur (cdr envs))])
(values (cons hd tl) (cons env envs)))))])
(values seq (merge-environments envs))))
(values (cons hd tl) (cons env envs))))))
(values seq (merge-environments envs)))
(define ((generator/attempts g) r s a e f)
(values (g a) e))
(define (mismatches-satisfied? env)
(let ([groups (make-hasheq)])
(define groups (make-hasheq))
(define (get-group group)
(hash-ref groups group
(λ ()
@ -258,7 +254,7 @@
(or (not (mismatch? name))
(let ([prior (get-group (mismatch-group name))])
(and (not (hash-ref prior val #f))
(hash-set! prior val #t)))))))
(hash-set! prior val #t))))))
(define empty-env #hash())
@ -269,12 +265,11 @@
(cons (make-bind (binder-name key) val) bindings)
bindings))))
(let*-values ([(langp lits lang-bases) (prepare-lang lang)]
[(sexpp _ sexp-bases) (prepare-lang sexp)]
[(lit-syms) (compiled-lang-literals lang)])
(letrec-values
([(compile)
(λ (pat any?)
(define-values (langp lits lang-bases) (prepare-lang lang))
(define-values (sexpp _ sexp-bases) (prepare-lang sexp))
(define lit-syms (compiled-lang-literals lang))
(define (compile pat any?)
(let* ([nt? (is-nt? (if any? sexpp langp))]
[mismatches? #f]
[generator
@ -402,34 +397,30 @@
(let ([g (λ (s a) (generator r s a e f))]
[p? (λ (_ e) (mismatches-satisfied? e))])
(generate/pred (unparse-pattern pat) g p? s a r)))
generator)))]
[(compile-non-terminals)
(λ (nts any?)
generator)))
(define (compile-non-terminals nts any?)
(make-immutable-hash
(map (λ (nt) (cons (nt-name nt)
(map (λ (p) (compile (rhs-pattern p) any?))
(nt-rhs nt))))
nts)))]
[(compile-language)
(λ (lang bases any?)
nts)))
(define (compile-language lang bases any?)
(make-rg-lang
(compile-non-terminals (compiled-lang-lang lang) any?)
(delay (compile-non-terminals (compiled-lang-cclang lang) any?))
bases))]
[(langc sexpc compile-pattern)
(values
(compile-language langp lang-bases #f)
(compile-language sexpp sexp-bases #t)
(λ (pat) (compile pat #f)))])
bases))
(define langc (compile-language langp lang-bases #f))
(define sexpc (compile-language sexpp sexp-bases #t))
(define (compile-pattern pat) (compile pat #f))
(λ (pat)
(let ([g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level)))])
(define g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level))))
(λ (size attempt retries)
(let-values ([(t e) (g retries size attempt empty-env the-hole)])
(define-values (t e) (g retries size attempt empty-env the-hole))
(values (let replace-the-not-hole ([t t])
(cond [(eq? t the-not-hole) the-hole]
[(list? t) (map replace-the-not-hole t)]
[else t]))
(bindings e)))))))))
(bindings e)))))
(define-struct base-cases (delayed-cross non-cross))
(define (base-cases-cross x) (force (base-cases-delayed-cross x)))
@ -997,7 +988,7 @@
(reduction-relation-make-procs r)))
(define (metafunction-srcs m)
(map (compose (curry format "clause at ~a") metafunc-case-src-loc)
(map (λ (x) (format "clause at ~a" (metafunc-case-src-loc x)))
(metafunc-proc-cases m)))
(define-syntax (check-reduction-relation stx)

4
collects/redex/private/struct.rkt
View File

@ -1,6 +1,6 @@
#lang racket
#lang racket/base
(require "matcher.rkt")
(require racket/list "matcher.rkt")
;; don't provide reduction-relation directly, so that we can use that for the macro's name.
(provide reduction-relation-lang