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

fixed sharing for quotes

Browse Source 
svn: r1704
This commit is contained in:
Philippe Meunier 2005-12-28 03:13:48 +00:00
parent 44806af30b
commit ee7119993b
1 changed files with 70 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

117
collects/mrflow/constraints-gen-and-prop.ss
View File

@ -13,6 +13,7 @@
"labels.ss" "labels.ss"
"types.ss" "types.ss"
"set-hash.ss" "set-hash.ss"
"assoc-set-hash.ss"
(prefix util: "util.ss") (prefix util: "util.ss")
(prefix hc: "hashcons.ss") (prefix hc: "hashcons.ss")
(prefix cst: "constants.ss") (prefix cst: "constants.ss")
@ -2283,52 +2284,73 @@
bound-label)) bound-label))
; sba-state syntax-object (listof (cons symbol label)) label (listof label) -> label ; sba-state syntax-object sexp (assoc-setof sexp label) -> label
(define (create-label-from-quote sba-state quoted-term gamma enclosing-lambda-label) ; must take sharing into account...
(let ([sexp-e (syntax-e quoted-term)]) (define (create-label-from-quote sba-state quoted-term unquoted-term assoc-set)
(cond ;(printf "Q: ~a ~a~n" unquoted-term (assoc-set-in? assoc-set unquoted-term))
[(list? sexp-e) (if (assoc-set-in? assoc-set unquoted-term)
(let loop ([sexp-e sexp-e]) (assoc-set-get assoc-set unquoted-term)
(if (null? sexp-e) (let ([sexp-e (syntax-e quoted-term)])
(let ([null-label (cond
(make-label-cst [(list? unquoted-term)
#f #f #f #f #t (let loop ([unquoted-term unquoted-term]
quoted-term [sexp-e sexp-e])
(make-hash-table) (if (null? unquoted-term)
(make-hash-table) (let ([null-label
'())]) (make-label-cst
(initialize-label-set-for-value-source null-label) #f #f #f #f #t
null-label) quoted-term
(let ([cons-label (make-hash-table)
(make-label-cons (make-hash-table)
#f #f #f #f #t unquoted-term)])
quoted-term (assoc-set-set assoc-set unquoted-term null-label)
(make-hash-table) (initialize-label-set-for-value-source null-label)
(make-hash-table) null-label)
(create-label-from-quote sba-state (car sexp-e) gamma enclosing-lambda-label) (let ([cons-label
(loop (cdr sexp-e)))]) (make-label-cons
(initialize-label-set-for-value-source cons-label) #f #f #f #f #t
cons-label)))] quoted-term
[(pair? sexp-e) (make-hash-table)
(let ([cons-label (make-hash-table)
(make-label-cons #f
#f #f #f #f #t #f)])
quoted-term (assoc-set-set assoc-set unquoted-term cons-label)
(make-hash-table) (set-label-cons-car!
(make-hash-table) cons-label
(create-label-from-quote sba-state (car sexp-e) gamma enclosing-lambda-label) (create-label-from-quote sba-state (car sexp-e) (car unquoted-term) assoc-set))
(create-label-from-quote sba-state (cdr sexp-e) gamma enclosing-lambda-label))]) (set-label-cons-cdr!
(initialize-label-set-for-value-source cons-label) cons-label
cons-label)] (loop (cdr unquoted-term) (cdr sexp-e)))
[else (let ([label (make-label-cst (initialize-label-set-for-value-source cons-label)
#f #f #f #f #f cons-label)))]
quoted-term [(pair? unquoted-term)
(make-hash-table) (let ([cons-label
(make-hash-table) (make-label-cons
sexp-e)]) #f #f #f #f #t
(initialize-label-set-for-value-source label) quoted-term
((sba-state-register-label-with-gui sba-state) label) (make-hash-table)
label)]))) (make-hash-table)
#f
#f)])
(assoc-set-set assoc-set unquoted-term cons-label)
(set-label-cons-car!
cons-label
(create-label-from-quote sba-state (car sexp-e) (car unquoted-term) assoc-set))
(set-label-cons-cdr!
cons-label
(create-label-from-quote sba-state (cdr sexp-e) (cdr unquoted-term) assoc-set))
(initialize-label-set-for-value-source cons-label)
cons-label)]
[else (let ([label (make-label-cst
#f #f #f #f #f
quoted-term
(make-hash-table)
(make-hash-table)
unquoted-term)])
(assoc-set-set assoc-set unquoted-term label)
(initialize-label-set-for-value-source label)
((sba-state-register-label-with-gui sba-state) label)
label)]))))
; Builds a list of labels of length n, with all labels being the same. ; Builds a list of labels of length n, with all labels being the same.
; This function should be seldom called, so it's not being made tail recursive... ; This function should be seldom called, so it's not being made tail recursive...
@ -2513,7 +2535,8 @@
((sba-state-register-label-with-gui sba-state) label) ((sba-state-register-label-with-gui sba-state) label)
label)] label)]
[(quote sexp) [(quote sexp)
(create-label-from-quote sba-state (syntax sexp) gamma enclosing-lambda-label)] (create-label-from-quote sba-state (syntax sexp)
(syntax-object->datum (syntax sexp)) (assoc-set-make))]
[(define-values vars exp) [(define-values vars exp)
(let* (; scheme list of syntax objects (let* (; scheme list of syntax objects
[vars (syntax-e (syntax vars))] [vars (syntax-e (syntax vars))]