116 lines
4.1 KiB
Racket
116 lines
4.1 KiB
Racket
;; 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.
|
|
#lang scheme
|
|
(provide (except-out (all-defined-out)
|
|
module-identifier=?))
|
|
(require (only-in srfi/1 any))
|
|
|
|
(define module-identifier=? free-identifier=?)
|
|
|
|
(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
|
|
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
|
|
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->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 #'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))
|