checkpointing progress toward applicable structs instead of hash table
This commit is contained in:
John Clements
parent
6ac65c3907
commit
6f84a1c143
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (prefix-in kernel: syntax/kerncase)
|
||||
mzlib/contract
|
||||
|
|
@ -9,7 +9,6 @@
|
|||
"shared.ss"
|
||||
"my-macros.ss"
|
||||
#;"xml-box.ss"
|
||||
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
|
||||
(prefix-in beginner-defined: "beginner-defined.ss")
|
||||
(for-syntax scheme/base))
|
||||
|
||||
|
|
@ -103,11 +102,14 @@
|
|||
|
||||
; top-level-rewrite : (SYNTAX-OBJECT -> SYNTAX-OBJECT)
|
||||
|
||||
; top-level-rewrite performs several tasks; it labels variables with their types (let-bound, lambda-bound, or non-lexical),
|
||||
; it flags if's which could come from cond's, it labels the begins in conds with 'stepper-skip annotations
|
||||
; top-level-rewrite performs several tasks; it labels variables with their types
|
||||
; (let-bound, lambda-bound, or non-lexical), it flags if's which could come from
|
||||
; cond's, it labels the begins in conds with 'stepper-skip annotations
|
||||
|
||||
; label-var-types returns a syntax object which is identical to the original except that the variable references are labeled
|
||||
; with the stepper-syntax-property 'stepper-binding-type, which is set to either let-bound, lambda-bound, or non-lexical.
|
||||
; label-var-types returns a syntax object which is identical to the original except
|
||||
; that the variable references are labeled with the stepper-syntax-property
|
||||
; 'stepper-binding-type, which is set to either let-bound, lambda-bound, or
|
||||
; non-lexical.
|
||||
|
||||
(define (top-level-rewrite stx)
|
||||
(let loop ([stx stx]
|
||||
|
|
@ -128,16 +130,30 @@
|
|||
[do-let/rec
|
||||
(lambda (stx rec?)
|
||||
(with-syntax ([(label ((vars rhs) ...) . bodies) stx])
|
||||
(let* ([vars-list (apply append (map syntax->list (syntax->list (syntax (vars ...)))))]
|
||||
[labelled-vars-list (map (lambda (var-list) (map (lambda (exp) (recur-with-bindings exp vars-list))
|
||||
(let* ([vars-list
|
||||
(apply append
|
||||
(map syntax->list
|
||||
(syntax->list (syntax (vars ...)))))]
|
||||
[labelled-vars-list
|
||||
(map (lambda (var-list)
|
||||
(map (lambda (exp)
|
||||
(recur-with-bindings exp vars-list))
|
||||
(syntax->list var-list)))
|
||||
(syntax->list (syntax (vars ...))))]
|
||||
[rhs-list (if rec?
|
||||
(map (lambda (exp) (recur-with-bindings exp vars-list)) (syntax->list #'(rhs ...)))
|
||||
[rhs-list
|
||||
(if rec?
|
||||
(map (lambda (exp)
|
||||
(recur-with-bindings exp vars-list))
|
||||
(syntax->list #'(rhs ...)))
|
||||
(map recur-regular (syntax->list #'(rhs ...))))]
|
||||
[new-bodies (map (lambda (exp) (recur-with-bindings exp vars-list)) (syntax->list #'bodies))]
|
||||
[new-bodies
|
||||
(map (lambda (exp)
|
||||
(recur-with-bindings exp vars-list))
|
||||
(syntax->list #'bodies))]
|
||||
[new-bindings (map list labelled-vars-list rhs-list)])
|
||||
(datum->syntax stx `(,#'label ,new-bindings ,@new-bodies) stx stx))))]
|
||||
(datum->syntax
|
||||
stx
|
||||
`(,#'label ,new-bindings ,@new-bodies) stx stx))))]
|
||||
|
||||
; evaluated at runtime, using 3D code:
|
||||
[put-into-xml-table (lambda (val)
|
||||
|
|
@ -476,48 +492,78 @@
|
|||
[lambda-clause-abstraction
|
||||
(lambda (clause)
|
||||
(with-syntax ([(args-stx . bodies) clause])
|
||||
(let*-2vals ([(annotated-body free-varrefs)
|
||||
; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies
|
||||
(match-let*
|
||||
([(vector annotated-body free-varrefs)
|
||||
; wrap bodies in explicit begin if more than 1
|
||||
; user-introduced (non-skipped) bodies
|
||||
; NB: CAN'T HAPPEN in beginner up through int/lambda
|
||||
(if (> (length (filter (lambda (clause)
|
||||
(not (stepper-syntax-property clause 'stepper-skip-completely)))
|
||||
(syntax->list (syntax bodies)))) 1)
|
||||
(let ([non-skipped-bodies
|
||||
(filter
|
||||
(lambda (clause)
|
||||
(not (skipped? clause)))
|
||||
(syntax->list (syntax bodies)))])
|
||||
(if (> (length non-skipped-bodies) 1)
|
||||
(lambda-body-recur (syntax (begin . bodies)))
|
||||
(let*-2vals ([(annotated-bodies free-var-sets)
|
||||
(2vals-map lambda-body-recur (syntax->list #`bodies))])
|
||||
(2vals #`(begin . #,annotated-bodies) (varref-set-union free-var-sets))))]
|
||||
[new-free-varrefs (varref-set-remove-bindings free-varrefs
|
||||
(match-let*
|
||||
([(vector annotated-bodies free-var-sets)
|
||||
(2vals-map lambda-body-recur
|
||||
(syntax->list #`bodies))])
|
||||
(vector #`(begin . #,annotated-bodies)
|
||||
(varref-set-union free-var-sets)))))]
|
||||
[new-free-varrefs
|
||||
(varref-set-remove-bindings
|
||||
free-varrefs
|
||||
(arglist-flatten #'args-stx))])
|
||||
(2vals (datum->syntax #'here `(,#'args-stx ,annotated-body) #'clause) new-free-varrefs))))]
|
||||
(vector (datum->syntax
|
||||
#'here
|
||||
`(,#'args-stx ,annotated-body) #'clause)
|
||||
new-free-varrefs))))]
|
||||
|
||||
[outer-lambda-abstraction
|
||||
(lambda (annotated-lambda free-varrefs)
|
||||
(let*-2vals
|
||||
([closure-info (make-debug-info-app 'all free-varrefs 'none)]
|
||||
;; if we manually disable the storage of names, lambdas get rendered as lambdas.
|
||||
[closure-name (if show-lambdas-as-lambdas?
|
||||
(match-let*
|
||||
([ap-struct-maker
|
||||
#`(#,annotated-proc #,annotated-lambda #f)]
|
||||
[closure-info (make-debug-info-app 'all free-varrefs 'none)]
|
||||
;; if we manually disable the storage of
|
||||
;; names, lambdas get rendered as lambdas.
|
||||
[closure-name
|
||||
(if show-lambdas-as-lambdas?
|
||||
#f
|
||||
(cond [(syntax? procedure-name-info) procedure-name-info]
|
||||
[(pair? procedure-name-info) (car procedure-name-info)]
|
||||
[(pair? procedure-name-info)
|
||||
(car procedure-name-info)]
|
||||
[else #f]))]
|
||||
[closure-storing-proc
|
||||
(opt-lambda (closure debug-info [lifted-index #f])
|
||||
(closure-table-put! closure (make-closure-record
|
||||
(closure-table-put! closure
|
||||
(make-closure-record
|
||||
closure-name
|
||||
debug-info
|
||||
#f
|
||||
lifted-index))
|
||||
closure)]
|
||||
;; gnarr! I can't find a test case
|
||||
;; that depends on the attachment of the inferred name...
|
||||
[inferred-name-lambda
|
||||
(if closure-name
|
||||
(syntax-property annotated-lambda 'inferred-name (syntax-e closure-name))
|
||||
(syntax-property
|
||||
annotated-lambda
|
||||
'inferred-name
|
||||
(syntax-e closure-name))
|
||||
annotated-lambda)]
|
||||
[captured
|
||||
(cond [(pair? procedure-name-info)
|
||||
#`(#%plain-app #,closure-storing-proc #,inferred-name-lambda #,closure-info
|
||||
#`(#%plain-app
|
||||
#,closure-storing-proc
|
||||
#,inferred-name-lambda
|
||||
#,closure-info
|
||||
#,(cadr procedure-name-info))]
|
||||
[else
|
||||
#`(#%plain-app #,closure-storing-proc #,inferred-name-lambda #,closure-info)])])
|
||||
#`(#%plain-app
|
||||
#,closure-storing-proc
|
||||
#,inferred-name-lambda
|
||||
#,closure-info)])])
|
||||
|
||||
(normal-bundle free-varrefs captured)))]
|
||||
|
||||
|
|
@ -803,17 +849,22 @@
|
|||
(kernel:kernel-syntax-case exp #f
|
||||
|
||||
[(#%plain-lambda . clause)
|
||||
(let*-2vals ([(annotated-clause free-varrefs)
|
||||
(lambda-clause-abstraction (syntax clause))]
|
||||
(match-let*
|
||||
([(vector annotated-clause free-varrefs)
|
||||
(lambda-clause-abstraction #'clause)]
|
||||
[annotated-lambda
|
||||
(with-syntax ([annotated-clause annotated-clause])
|
||||
(syntax/loc exp (#%plain-lambda . annotated-clause)))])
|
||||
(syntax/loc exp
|
||||
(#%plain-lambda . annotated-clause)))])
|
||||
(outer-lambda-abstraction annotated-lambda free-varrefs))]
|
||||
|
||||
[(case-lambda . clauses)
|
||||
(let*-2vals ([(annotated-cases free-varrefs-cases)
|
||||
(2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))]
|
||||
[annotated-case-lambda (with-syntax ([annotated-cases annotated-cases])
|
||||
(match-let*
|
||||
([(vector annotated-cases free-varrefs-cases)
|
||||
(2vals-map lambda-clause-abstraction
|
||||
(syntax->list (syntax clauses)))]
|
||||
[annotated-case-lambda
|
||||
(with-syntax ([annotated-cases annotated-cases])
|
||||
(syntax/loc exp (case-lambda . annotated-cases)))]
|
||||
[free-varrefs (varref-set-union free-varrefs-cases)])
|
||||
(outer-lambda-abstraction annotated-case-lambda free-varrefs))]
|
||||
|
|
@ -1225,3 +1276,7 @@
|
|||
|
||||
(define (stepper-recertify new-stx old-stx)
|
||||
(syntax-recertify new-stx old-stx saved-code-inspector #f))
|
||||
|
||||
;; does this stx have the 'stepper-skip-completely property?
|
||||
(define (skipped? stx)
|
||||
(stepper-syntax-property stx 'stepper-skip-completely))
|
||||
|
|
@ -1,6 +1,5 @@
|
|||
(module my-macros mzscheme
|
||||
#lang racket
|
||||
|
||||
(require-for-syntax mzlib/list)
|
||||
|
||||
;;;;;;;;;;
|
||||
;;
|
||||
|
|
@ -13,7 +12,7 @@
|
|||
(define-syntax (lx stx)
|
||||
(syntax-case stx ()
|
||||
[(lx term)
|
||||
(with-syntax ([binder (datum->syntax-object (syntax term) `_)])
|
||||
(with-syntax ([binder (datum->syntax (syntax term) `_)])
|
||||
(syntax (lambda (binder) term)))]))
|
||||
|
||||
|
||||
|
|
@ -83,7 +82,7 @@
|
|||
(2vals null null)
|
||||
(let*-2vals ([(a b) (apply f (map car lsts))]
|
||||
[(a-rest b-rest) (apply 2vals-map f (map cdr lsts))])
|
||||
(2vals (cons a a-rest) (cons b b-rest))))))
|
||||
(2vals (cons a a-rest) (cons b b-rest)))))
|
||||
|
||||
; test cases
|
||||
; (require my-macros)
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
#lang scheme
|
||||
#lang racket
|
||||
|
||||
(require "my-macros.ss"
|
||||
(require "my-macros.rkt"
|
||||
srfi/26
|
||||
scheme/class)
|
||||
|
||||
#;(require (for-syntax mzlib/list))
|
||||
|
||||
; CONTRACTS
|
||||
|
||||
|
|
@ -24,7 +23,10 @@
|
|||
[binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)]
|
||||
[binding-set-union (-> (listof binding-set?) binding-set?)]
|
||||
[varref-set-union (-> (listof varref-set?) varref-set?)]
|
||||
[skipto/auto (syntax? (symbols 'rebuild 'discard) (syntax? . -> . syntax?) . -> . syntax?)]
|
||||
[skipto/auto (syntax? (symbols 'rebuild 'discard)
|
||||
(syntax? . -> . syntax?)
|
||||
. -> .
|
||||
syntax?)]
|
||||
[in-closure-table (-> any/c boolean?)]
|
||||
[sublist (-> number? number? list? list?)]
|
||||
[attach-info (-> syntax? syntax? syntax?)]
|
||||
|
|
@ -98,12 +100,16 @@
|
|||
skipto/fourth
|
||||
skipto/firstarg
|
||||
|
||||
(struct-out annotated-proc)
|
||||
|
||||
view-controller^
|
||||
stepper-frame^
|
||||
)
|
||||
|
||||
;; stepper-syntax-property : like syntax property, but adds properties to an association
|
||||
;; list associated with the syntax property 'stepper-properties
|
||||
;; 2010-12-05: I no longer see any reason not just to use the regular
|
||||
;; syntax-property for this...
|
||||
(define stepper-syntax-property
|
||||
(case-lambda
|
||||
[(stx tag) (let ([stepper-props (syntax-property stx 'stepper-properties)])
|
||||
|
|
@ -678,8 +684,8 @@
|
|||
stx)]))
|
||||
|
||||
|
||||
;; the xml-snip-creation@ unit accepts the xml-snip% and scheme-snip% classes and provides
|
||||
;; functions which map a "spec" to an xml-snip.
|
||||
;; the xml-snip-creation@ unit accepts the xml-snip% and scheme-snip% classes and
|
||||
;; provides functions which map a "spec" to an xml-snip.
|
||||
;; An xml-spec is (listof xml-spec-elt)
|
||||
;; An xml-spec-elt is either
|
||||
;; - a string,
|
||||
|
|
@ -720,12 +726,23 @@
|
|||
(car (last-pair (send language get-language-position))))
|
||||
|
||||
|
||||
;; per Robby's suggestion: rather than using a hash table for
|
||||
;; lambdas, just use an applicable structure instead.
|
||||
|
||||
;; An annotated procedure is represented at runtime by
|
||||
;; an applicable structure that stores stepper information.
|
||||
(struct annotated-proc (base info)
|
||||
#:property prop:procedure
|
||||
(struct-field-index base))
|
||||
|
||||
|
||||
(define-signature view-controller^ (go))
|
||||
(define-signature stepper-frame^ (stepper-frame%))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
; test cases
|
||||
;(require shared)
|
||||
;(write (collection-path "tests" "mzscheme"))
|
||||
|
|
|
|||
|
|
@ -213,6 +213,15 @@
|
|||
-> ,@defs {(+ 12 9)}
|
||||
-> ,@defs {21}))
|
||||
|
||||
;;intermediate/lambda hof
|
||||
(let ([defs `((define (a x)
|
||||
(lambda (y) (+ x y)))
|
||||
(define b (a 9)))])
|
||||
(t 'intermediate-lambda-hof m:intermediate-lambda
|
||||
,@defs (b 5)
|
||||
:: ,@defs {(b 5)}
|
||||
-> @defs {'zoofrenzy}))
|
||||
|
||||
;;;;;;;;;;;;
|
||||
;;
|
||||
;; OR / AND
|
||||
|
|
@ -604,9 +613,16 @@
|
|||
|
||||
(t1 'let-deriv
|
||||
m:intermediate "(define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))"
|
||||
(let ([defs `((define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))])
|
||||
`((before-after (,@defs (define gprime (hilite (f cos))))
|
||||
(,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))))
|
||||
(let ([defs `((define (f g)
|
||||
(let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))])
|
||||
gp)))])
|
||||
`((before-after (,@defs (define gprime
|
||||
(hilite (f cos))))
|
||||
(,@defs (define gprime
|
||||
(hilite (let ([gp (lambda (x)
|
||||
(/ (- (cos (+ x 0.1)) (cos x))
|
||||
0.001))])
|
||||
gp)))))
|
||||
(before-after (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))
|
||||
(,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0))))
|
||||
(finished-stepping))))
|
||||
|
|
@ -625,6 +641,8 @@
|
|||
((define f_0 (lambda (x) (+ x 13))) (define a (hilite (lambda (x) (+ x 13))))))
|
||||
(finished-stepping)))
|
||||
|
||||
|
||||
|
||||
;;;;;;;;;;;;;
|
||||
;;
|
||||
;; LET*
|
||||
|
|
@ -1486,4 +1504,5 @@
|
|||
check-error check-error-bad))
|
||||
#;(run-tests '(teachpack-universe))
|
||||
#;(run-all-tests)
|
||||
(run-tests '(check-expect))))
|
||||
(run-tests '(intermediate-lambda-hof))
|
||||
))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user