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

fix property & file format mess

Browse Source 
svn: r5343
This commit is contained in:
Eli Barzilay 2007-01-12 23:55:37 +00:00
parent 441a48c33b
commit 9711964d4f
2 changed files with 894 additions and 894 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1558
collects/frtime/frtime-opt.ss Executable file → Normal file
View File

File diff suppressed because it is too large Load Diff

230
collects/frtime/lowered-equivs.ss
View File

@ -1,115 +1,115 @@
;; This module defines all the logic necessary for working with lowered
;; equivalents at the syntactic level. That is, it treats functions simply
;; as syntactic identifiers.
(module lowered-equivs mzscheme
(provide (all-defined))
(require (lib "list.ss"))
(require (only (lib "1.ss" "srfi") any))
(define lowered-equiv-suffix ":lowered-equiv")
;; Given an identifier for a normal binding, return the identifier
;; to be used for the lowered equivalent of that binding.
(define (make-lowered-equiv-id id-stx)
(datum->syntax-object
id-stx
(string->symbol
(format "~a~a" (syntax-e id-stx) lowered-equiv-suffix))))
;; does the given string end with the given suffix?
(define (string-ends-with str suffix)
(string=? (substring str (max 0 (- (string-length str)
(string-length suffix))))
suffix))
;; is the given identifier a lowered equiv identifier?
(define (lowered-equiv-id? id-stx)
(and (identifier? id-stx)
(string-ends-with (symbol->string (syntax-e id-stx))
lowered-equiv-suffix)))
;; strip the lowered-equiv suffix from an identifier
(define (lowered-equiv-id->lifted-id id-stx)
(let ([name (symbol->string (syntax-e id-stx))])
(datum->syntax-object
id-stx
(string->symbol
(substring name 0 (- (string-length name)
(string-length lowered-equiv-suffix)))))))
;; Exception used to indicate that an expression cannot be lowered because
;; it has no lowered equivalent.
(define-struct exn:no-lowered-equiv (reason))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Equiv maps translate function names to the name of a lowered equivalent.
;; Equiv maps are represented as a list of (func . lowered-equiv) pairs.
;; empty equiv map
(define (empty-equiv-map)
(list))
;; add a new func/lowered-equiv mapping to an equiv map (overwrites any
;; existing mapping)
(define (add-equiv-map old-equiv-map new-func new-lowered-func)
(cons (cons new-func new-lowered-func)
old-equiv-map))
;; remove a func/lowered-equiv mapping from an equiv map (no effect if
;; the func isn't actually in the mapping)
(define (del-equiv-map old-equiv-map func-to-remove)
(filter (lambda (pair)
(not (module-identifier=? (car pair) func-to-remove)))
old-equiv-map))
;; remove a list of funcs from an equiv map
(define (del-equiv-map* old-equiv-map ids-to-remove)
(foldl del-equiv-map old-equiv-map ids-to-remove))
;; Returns the lowered-equiv for a function, or #f if there is none.
(define (lookup-lowered-equiv equiv-map func)
(if (null? equiv-map)
#f
(if (module-identifier=? (caar equiv-map) func)
(cdar equiv-map)
(lookup-lowered-equiv (cdr equiv-map) func))))
;; Returns the lowered-equiv for a function, or throws exn:no-lowered-equiv.
(define (get-lowered-equiv equiv-map func)
(let ([ret (lookup-lowered-equiv equiv-map func)])
(if ret
ret
(raise (make-exn:no-lowered-equiv
(format "no lowered equiv for ~s" (syntax-object->datum func)))))))
;; convert syntax of the form ((func lowered-equiv) ...) to an equiv map
(define (stx-to-equiv-map stx)
(syntax-case stx ()
(() (empty-equiv-map))
(((lifted lowered) rest ...)
(add-equiv-map (stx-to-equiv-map #'(rest ...)) #'lifted #'lowered))))
;; convert an equiv map to syntax of the form ((func lowered-equiv) ...)
(define (equiv-map-to-stx equiv-map)
(datum->syntax-object #'here
(map (lambda (pair) (list (car pair) (cdr pair)))
equiv-map)))
;; combine two equiv maps
(define (union-equiv-maps . equiv-maps)
(apply append equiv-maps))
;; convert a list of symbols to an equiv map, by searching for symbols
;; that have a matching lowered equivalent symbol. All other symbols
;; are ignored.
(define (symbol-list-to-equiv-map symbol-list)
(foldl (lambda (func equiv-map)
(if (lowered-equiv-id? func)
(add-equiv-map
equiv-map
(lowered-equiv-id->lifted-id func) func)
equiv-map))
(empty-equiv-map)
symbol-list))
)
;; This module defines all the logic necessary for working with lowered
;; equivalents at the syntactic level. That is, it treats functions simply
;; as syntactic identifiers.
(module lowered-equivs mzscheme
(provide (all-defined))
(require (lib "list.ss"))
(require (only (lib "1.ss" "srfi") any))
(define lowered-equiv-suffix ":lowered-equiv")
;; Given an identifier for a normal binding, return the identifier
;; to be used for the lowered equivalent of that binding.
(define (make-lowered-equiv-id id-stx)
(datum->syntax-object
id-stx
(string->symbol
(format "~a~a" (syntax-e id-stx) lowered-equiv-suffix))))
;; does the given string end with the given suffix?
(define (string-ends-with str suffix)
(string=? (substring str (max 0 (- (string-length str)
(string-length suffix))))
suffix))
;; is the given identifier a lowered equiv identifier?
(define (lowered-equiv-id? id-stx)
(and (identifier? id-stx)
(string-ends-with (symbol->string (syntax-e id-stx))
lowered-equiv-suffix)))
;; strip the lowered-equiv suffix from an identifier
(define (lowered-equiv-id->lifted-id id-stx)
(let ([name (symbol->string (syntax-e id-stx))])
(datum->syntax-object
id-stx
(string->symbol
(substring name 0 (- (string-length name)
(string-length lowered-equiv-suffix)))))))
;; Exception used to indicate that an expression cannot be lowered because
;; it has no lowered equivalent.
(define-struct exn:no-lowered-equiv (reason))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Equiv maps translate function names to the name of a lowered equivalent.
;; Equiv maps are represented as a list of (func . lowered-equiv) pairs.
;; empty equiv map
(define (empty-equiv-map)
(list))
;; add a new func/lowered-equiv mapping to an equiv map (overwrites any
;; existing mapping)
(define (add-equiv-map old-equiv-map new-func new-lowered-func)
(cons (cons new-func new-lowered-func)
old-equiv-map))
;; remove a func/lowered-equiv mapping from an equiv map (no effect if
;; the func isn't actually in the mapping)
(define (del-equiv-map old-equiv-map func-to-remove)
(filter (lambda (pair)
(not (module-identifier=? (car pair) func-to-remove)))
old-equiv-map))
;; remove a list of funcs from an equiv map
(define (del-equiv-map* old-equiv-map ids-to-remove)
(foldl del-equiv-map old-equiv-map ids-to-remove))
;; Returns the lowered-equiv for a function, or #f if there is none.
(define (lookup-lowered-equiv equiv-map func)
(if (null? equiv-map)
#f
(if (module-identifier=? (caar equiv-map) func)
(cdar equiv-map)
(lookup-lowered-equiv (cdr equiv-map) func))))
;; Returns the lowered-equiv for a function, or throws exn:no-lowered-equiv.
(define (get-lowered-equiv equiv-map func)
(let ([ret (lookup-lowered-equiv equiv-map func)])
(if ret
ret
(raise (make-exn:no-lowered-equiv
(format "no lowered equiv for ~s" (syntax-object->datum func)))))))
;; convert syntax of the form ((func lowered-equiv) ...) to an equiv map
(define (stx-to-equiv-map stx)
(syntax-case stx ()
(() (empty-equiv-map))
(((lifted lowered) rest ...)
(add-equiv-map (stx-to-equiv-map #'(rest ...)) #'lifted #'lowered))))
;; convert an equiv map to syntax of the form ((func lowered-equiv) ...)
(define (equiv-map-to-stx equiv-map)
(datum->syntax-object #'here
(map (lambda (pair) (list (car pair) (cdr pair)))
equiv-map)))
;; combine two equiv maps
(define (union-equiv-maps . equiv-maps)
(apply append equiv-maps))
;; convert a list of symbols to an equiv map, by searching for symbols
;; that have a matching lowered equivalent symbol. All other symbols
;; are ignored.
(define (symbol-list-to-equiv-map symbol-list)
(foldl (lambda (func equiv-map)
(if (lowered-equiv-id? func)
(add-equiv-map
equiv-map
(lowered-equiv-id->lifted-id func) func)
equiv-map))
(empty-equiv-map)
symbol-list))
)