.
original commit: b8c8af76a2ee47e8d207f165842a6bef12b9c3aa
This commit is contained in:
Matthew Flatt
parent
c289919340
commit
d1d3239767
828
collects/mzlib/class.ss
Normal file
828
collects/mzlib/class.ss
Normal file
|
|
@ -0,0 +1,828 @@
|
|||
|
||||
;; Object system, same as MzScheme version 103 and earlier
|
||||
|
||||
(module class mzscheme
|
||||
(import-for-syntax mzscheme)
|
||||
|
||||
(define-struct obj (class slots))
|
||||
(define-struct class (name
|
||||
object-make width
|
||||
pos supers
|
||||
interface
|
||||
public-ht public-ids
|
||||
init-old-indices ;; rename
|
||||
init-define-indices ;; override, public
|
||||
replace-indices ;; override
|
||||
init-new-indices ;; inherit, override, public
|
||||
go go-arity))
|
||||
;; simplistic implementation for now:
|
||||
(define-struct interface (name supers public-ids class))
|
||||
|
||||
(define undefined (letrec ([x x]) x))
|
||||
|
||||
(define object<%> (make-interface 'object% null null #f))
|
||||
(define object% (make-class 'object%
|
||||
make-obj 0
|
||||
0 (vector #f)
|
||||
object<%>
|
||||
(make-hash-table)
|
||||
null null null null null
|
||||
(lambda ()
|
||||
(let ([object%-init (lambda () (void))])
|
||||
object%-init))
|
||||
0))
|
||||
(set-interface-class! object<%> object%)
|
||||
(vector-set! (class-supers object%) 0 object%)
|
||||
|
||||
(define-struct (exn:object struct:exn) ())
|
||||
|
||||
(define (obj-error where . msg)
|
||||
(raise
|
||||
(make-exn:object
|
||||
(string-append
|
||||
(format "~a: " where)
|
||||
(apply format msg))
|
||||
(current-continuation-marks))))
|
||||
|
||||
(define (for-class name)
|
||||
(if name (format " for class: ~a" name) ""))
|
||||
(define (for-intf name)
|
||||
(if name (format " for interface: ~a" name) ""))
|
||||
|
||||
(define (get-implement-requirement interfaces where for)
|
||||
(let loop ([class #f]
|
||||
[supers interfaces])
|
||||
(if (null? supers)
|
||||
class
|
||||
(let ([c (interface-class (car supers))])
|
||||
(loop
|
||||
(cond
|
||||
[(not c) class]
|
||||
[(not class) c]
|
||||
[(subclass? c class) class]
|
||||
[(subclass? class c) c]
|
||||
[else
|
||||
(obj-error
|
||||
where
|
||||
"conflicting class implementation requirements in superinterfaces~a"
|
||||
for)])
|
||||
(cdr supers))))))
|
||||
|
||||
(define (compose-class name super interfaces
|
||||
use-pre-ids ;; rename
|
||||
use-final-ids ;; inherit
|
||||
replace-ids ;; override
|
||||
new-ids ;; public
|
||||
go go-arity)
|
||||
(unless (class? super)
|
||||
(obj-error 'class*/names "superclass expression returned a non-class: ~a~a"
|
||||
super
|
||||
(for-class name)))
|
||||
(let ([name (or name
|
||||
(let ([s (class-name super)])
|
||||
(and s
|
||||
(not (eq? super object%))
|
||||
(if (symbol? s)
|
||||
(format "derived-from-~a" s)
|
||||
s))))])
|
||||
(for-each
|
||||
(lambda (intf)
|
||||
(unless (interface? intf)
|
||||
(obj-error 'class*/names "interface expression returned a non-interface: ~a~a"
|
||||
intf
|
||||
(for-class name))))
|
||||
interfaces)
|
||||
(let ([ht (make-hash-table)]
|
||||
[super-public-ids (class-public-ids super)])
|
||||
;; Put superclass ids in table, with pos
|
||||
(let loop ([ids super-public-ids][p 0])
|
||||
(unless (null? ids)
|
||||
(hash-table-put! ht (car ids) p)
|
||||
(loop (cdr ids) (add1 p))))
|
||||
;; Put new ids in table, with pos
|
||||
(let loop ([ids new-ids][p (class-width super)])
|
||||
(unless (null? ids)
|
||||
(when (hash-table-get ht (car ids) (lambda () #f))
|
||||
(obj-error 'class*/names "superclass already contains ivar: ~a~a"
|
||||
(car ids)
|
||||
(for-class name)))
|
||||
(hash-table-put! ht (car ids) p)
|
||||
(loop (cdr ids) (add1 p))))
|
||||
;; Check that superclass has expected ids, and get indices
|
||||
(let ([get-indices
|
||||
(lambda (ids)
|
||||
(map
|
||||
(lambda (id)
|
||||
(hash-table-get
|
||||
ht id
|
||||
(lambda ()
|
||||
(obj-error 'class*/names
|
||||
"superclass does not provide an expected ivar: ~a~a"
|
||||
id
|
||||
(for-class name)))))
|
||||
ids))])
|
||||
(let ([define-indices (get-indices (append replace-ids new-ids))]
|
||||
[use-pre-indices (get-indices use-pre-ids)]
|
||||
[use-final-indices (get-indices use-final-ids)]
|
||||
[replace-indices (get-indices replace-ids)]
|
||||
[new-indices (get-indices new-ids)]
|
||||
[width (+ (class-width super) (length new-ids))])
|
||||
;; Check here that all interface ivars are satisfied
|
||||
(for-each
|
||||
(lambda (intf)
|
||||
(for-each
|
||||
(lambda (var)
|
||||
(unless (hash-table-get ht var (lambda () #f))
|
||||
(obj-error 'class*/names
|
||||
"interface-required variable missing: ~a~a~a"
|
||||
var
|
||||
(for-class name)
|
||||
(for-intf (interface-name intf)))))
|
||||
(interface-public-ids intf)))
|
||||
interfaces)
|
||||
(let ([c (get-implement-requirement interfaces 'class*/names (for-class name))])
|
||||
(when (and c (not (subclass? super c)))
|
||||
(obj-error 'class*/names
|
||||
"interface-required implementation not satisfied~a~a"
|
||||
(for-class name)
|
||||
(let ([r (class-name c)])
|
||||
(if r
|
||||
(format " required class: ~a" r)
|
||||
"")))))
|
||||
;; Make the class and its interface
|
||||
(let* ([class-make (if name
|
||||
(make-naming-constructor
|
||||
struct:class
|
||||
(string->symbol (format "class:~a" name)))
|
||||
make-class)]
|
||||
[object-make (if name
|
||||
(make-naming-constructor
|
||||
struct:obj
|
||||
(string->symbol (format "object:~a" name)))
|
||||
make-obj)]
|
||||
[interface-make (if name
|
||||
(make-naming-constructor
|
||||
struct:interface
|
||||
(string->symbol (format "interface:~a" name)))
|
||||
make-interface)]
|
||||
[public-ids (append super-public-ids new-ids)]
|
||||
[super-interfaces (cons (class-interface super) interfaces)]
|
||||
[i (interface-make name super-interfaces public-ids #f)]
|
||||
[c (class-make name
|
||||
object-make width
|
||||
(add1 (class-pos super))
|
||||
(list->vector (append (vector->list (class-supers super)) (list #f)))
|
||||
i
|
||||
ht public-ids
|
||||
use-pre-indices ;; rename
|
||||
define-indices ;; override, public
|
||||
replace-indices ;; override
|
||||
(append use-final-indices replace-indices new-indices) ;; inherit, override, public
|
||||
go (if (box? go-arity)
|
||||
(make-arity-at-least (unbox go-arity))
|
||||
go-arity))])
|
||||
(vector-set! (class-supers c) (class-pos c) c)
|
||||
(set-interface-class! i c)
|
||||
c))))))
|
||||
|
||||
(define (compose-interface name supers vars)
|
||||
(for-each
|
||||
(lambda (intf)
|
||||
(unless (interface? intf)
|
||||
(obj-error 'interface
|
||||
"superinterface expression returned a non-interface: ~a~a"
|
||||
intf
|
||||
(for-intf name))))
|
||||
supers)
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each
|
||||
(lambda (var)
|
||||
(hash-table-put! ht var #t))
|
||||
vars)
|
||||
;; Check that vars don't already exist in supers:
|
||||
(for-each
|
||||
(lambda (super)
|
||||
(for-each
|
||||
(lambda (var)
|
||||
(when (hash-table-get ht var (lambda () #f))
|
||||
(obj-error 'interface "variable already in superinterface: ~a~a~a"
|
||||
var
|
||||
(for-intf name)
|
||||
(let ([r (interface-name super)])
|
||||
(if r
|
||||
(format " already in: ~a" r)
|
||||
"")))))
|
||||
(interface-public-ids super)))
|
||||
supers)
|
||||
;; Check for [conflicting] implementation requirements
|
||||
(let ([class (get-implement-requirement supers 'interface (for-intf name))]
|
||||
[interface-make (if name
|
||||
(make-naming-constructor
|
||||
struct:interface
|
||||
(string->symbol (format "interface:~a" name)))
|
||||
make-interface)])
|
||||
;; Add supervars to table:
|
||||
(for-each
|
||||
(lambda (super)
|
||||
(for-each
|
||||
(lambda (var) (hash-table-put! ht var #t))
|
||||
(interface-public-ids super)))
|
||||
supers)
|
||||
;; Done
|
||||
(interface-make name supers (hash-table-map ht (lambda (k v) k)) class))))
|
||||
|
||||
(define (make-object c . args)
|
||||
(unless (class? c)
|
||||
(apply raise-type-error 'make-object "class" 0 c args))
|
||||
(let ([v (make-vector (class-width c))])
|
||||
(let loop ([n (class-width c)])
|
||||
(unless (= n 0)
|
||||
(vector-set! v (sub1 n) (box undefined))
|
||||
(loop (sub1 n))))
|
||||
(let ([this ((class-object-make c) c v)])
|
||||
(let ([setup (let setup-class ([c c])
|
||||
(if (zero? (class-pos c))
|
||||
(lambda ()
|
||||
((class-go c)))
|
||||
(let ([super (vector-ref (class-supers c)
|
||||
(sub1 (class-pos c)))])
|
||||
(let ([super-setup (setup-class super)])
|
||||
(let ([old-boxes (map (lambda (i)
|
||||
(vector-ref v i))
|
||||
(class-init-old-indices c))])
|
||||
(for-each (lambda (i)
|
||||
(vector-set! v i (box undefined)))
|
||||
(class-replace-indices c))
|
||||
(let ([define-boxes (map (lambda (i)
|
||||
(vector-ref v i))
|
||||
(class-init-define-indices c))])
|
||||
(lambda ()
|
||||
(let ([new-boxes (map (lambda (i)
|
||||
(vector-ref v i))
|
||||
(class-init-new-indices c))]
|
||||
[super-init (super-setup)]
|
||||
[super-called? #f])
|
||||
(letrec ([init (apply
|
||||
(class-go c)
|
||||
this
|
||||
(lambda args
|
||||
(when super-called?
|
||||
(obj-error (or (inferred-name init)
|
||||
'object-init)
|
||||
"multiple intializations of superclass"))
|
||||
(set! super-called? #t)
|
||||
(apply super-init args))
|
||||
(append
|
||||
define-boxes ;; override, public
|
||||
old-boxes ;; rename
|
||||
new-boxes))]) ;; inherit, override, public
|
||||
(lambda args
|
||||
(apply init args)
|
||||
(unless super-called?
|
||||
(obj-error
|
||||
(or (inferred-name init)
|
||||
'object-init)
|
||||
"initialization did not invoke superclass initializer"))))))))))))])
|
||||
(apply (setup) args)
|
||||
this))))
|
||||
|
||||
(define object? obj?)
|
||||
|
||||
(define (is-a? v c)
|
||||
(cond
|
||||
[(class? c)
|
||||
(and (obj? v)
|
||||
(subclass? (obj-class v) c))]
|
||||
[(interface? c)
|
||||
(and (obj? v)
|
||||
(implementation? (obj-class v) c))]
|
||||
[else (raise-type-error 'is-a? "class or interface" 1 v c)]))
|
||||
|
||||
(define (subclass? v c)
|
||||
(unless (class? c)
|
||||
(raise-type-error 'subclass? "class" 1 v c))
|
||||
(and (class? v)
|
||||
(let ([p (class-pos c)])
|
||||
(and (<= p (class-pos v))
|
||||
(eq? c (vector-ref (class-supers v) p))))))
|
||||
|
||||
(define class->interface class-interface)
|
||||
(define (object-interface o) (class-interface (obj-class o)))
|
||||
|
||||
(define (implementation? v i)
|
||||
(unless (interface? i)
|
||||
(raise-type-error 'implementation? "interface" 1 v i))
|
||||
(and (class? v)
|
||||
(interface-extension? (class->interface v) i)))
|
||||
|
||||
(define (interface-extension? v i)
|
||||
(unless (interface? i)
|
||||
(raise-type-error 'interface-extension? "interface" 1 v i))
|
||||
(and (interface? i)
|
||||
(let loop ([v v])
|
||||
(or (eq? v i)
|
||||
(ormap loop (interface-supers v))))))
|
||||
|
||||
(define (ivar-in-interface? s i)
|
||||
(unless (symbol? s)
|
||||
(raise-type-error 'ivar-in-interface? "symbol" 0 s i))
|
||||
(unless (interface? i)
|
||||
(raise-type-error 'ivar-in-interface? "interface" 1 s i))
|
||||
(and (memq s (interface-public-ids i)) #t))
|
||||
|
||||
(define (interface->ivar-names i)
|
||||
(unless (interface? i)
|
||||
(raise-type-error 'interface->ivar-names "interface" i))
|
||||
; copy list
|
||||
(map values (interface-public-ids i)))
|
||||
|
||||
(define (class-initialization-arity c)
|
||||
(unless (class? c)
|
||||
(raise-type-error 'class-initialization-arity "class" c))
|
||||
(class-go-arity c))
|
||||
|
||||
(define (ivar/proc o n)
|
||||
(unless (obj? o)
|
||||
(raise-type-error 'ivar/proc "object" 0 o n))
|
||||
(let ([p (hash-table-get
|
||||
(class-public-ht (obj-class o))
|
||||
n
|
||||
(lambda () #f))])
|
||||
(if p
|
||||
(unbox (vector-ref (obj-slots o) p))
|
||||
(begin
|
||||
(unless (symbol? n)
|
||||
(raise-type-error 'ivar/proc "symbol" 1 o n))
|
||||
(obj-error 'ivar
|
||||
"instance variable not found: ~e~a in: ~e"
|
||||
n
|
||||
(for-class (class-name (obj-class o)))
|
||||
o)))))
|
||||
|
||||
(define-syntax ivar
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ o m)
|
||||
(identifier? (syntax m))
|
||||
(syntax (ivar/proc o 'm))])))
|
||||
|
||||
(define-syntax send
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ o m arg ...)
|
||||
(identifier? (syntax m))
|
||||
(syntax ((ivar o m) arg ...))])))
|
||||
|
||||
(define (make-generic/proc c n)
|
||||
(unless (or (class? c) (interface? c))
|
||||
(raise-type-error 'make-generic "class or interface" 0 c n))
|
||||
(unless (symbol? n)
|
||||
(raise-type-error 'make-generic/proc "symbol" 1 c n))
|
||||
(if (class? c)
|
||||
(let ([p (hash-table-get
|
||||
(class-public-ht c)
|
||||
n
|
||||
(lambda () #f))])
|
||||
(if p
|
||||
(lambda (o)
|
||||
(unless (is-a? o c)
|
||||
(let ([name (string->symbol (format "generic~a" (for-class (class-name c))))])
|
||||
(if (obj? o)
|
||||
(obj-error name
|
||||
"object not an instance of the generic's class: ~e"
|
||||
o)
|
||||
(raise-type-error
|
||||
name
|
||||
"object"
|
||||
o))))
|
||||
(unbox (vector-ref (obj-slots o) p)))
|
||||
(obj-error 'make-generic
|
||||
"instance variable not found: ~e~a"
|
||||
n
|
||||
(for-class (class-name c)))))
|
||||
(begin
|
||||
(unless (memq n (interface-public-ids c))
|
||||
(obj-error 'make-generic
|
||||
"instance variable not found: ~e~a"
|
||||
n
|
||||
(for-intf (interface-name c))))
|
||||
(lambda (o)
|
||||
(unless (is-a? o c)
|
||||
(let ([name (string->symbol (format "generic~a" (for-intf (interface-name c))))])
|
||||
(if (obj? o)
|
||||
(obj-error name
|
||||
"object not an instance of the generic's interface: ~e"
|
||||
o)
|
||||
(raise-type-error
|
||||
name
|
||||
"object"
|
||||
o))))
|
||||
(ivar/proc o n)))))
|
||||
|
||||
(define-syntax make-generic
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ c n)
|
||||
(identifier? (syntax n))
|
||||
(syntax
|
||||
(make-generic/proc c 'n))])))
|
||||
|
||||
(define needs-init (gensym))
|
||||
|
||||
(define-syntax class*/names
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (this-id super-init-id)
|
||||
super-expr
|
||||
(interface-expr ...)
|
||||
init-vars
|
||||
clauses ...)
|
||||
(let ([se (lambda (msg expr)
|
||||
(raise-syntax-error 'class*/names msg stx expr))])
|
||||
;; Check this and super-init:
|
||||
(unless (identifier? (syntax this-id))
|
||||
(se "not an identifier" (syntax this-id)))
|
||||
(unless (identifier? (syntax super-init-id))
|
||||
(se "not an identifier" (syntax super-init-id)))
|
||||
;; Unpack init arguments, with default expressions:
|
||||
(let-values ([(init-ids init-defs init-rest-id)
|
||||
(let loop ([inits (syntax init-vars)][need-def? #f])
|
||||
(syntax-case inits ()
|
||||
[() (values null null #f)]
|
||||
[id (identifier? (syntax id))
|
||||
(values null null (syntax id))]
|
||||
[(id . rest) (identifier? (syntax id))
|
||||
(begin
|
||||
(when need-def?
|
||||
(se "expected identifier with default value" (syntax id)))
|
||||
(let-values ([(ids defs rest) (loop (syntax rest) #f)])
|
||||
(values (cons (syntax id) ids)
|
||||
(cons #f defs)
|
||||
rest)))]
|
||||
[((id def) . rest) (identifier? (syntax id))
|
||||
(let-values ([(ids defs rest) (loop (syntax rest) #f)])
|
||||
(values (cons (syntax id) ids)
|
||||
(cons (syntax def) defs)
|
||||
rest))]
|
||||
[(first . rest)
|
||||
(se "bad initialization declaration" (syntax first))]
|
||||
[else (se "improper identifier list" (syntax init-vars))]))])
|
||||
;; Unpack all body clauses:
|
||||
(let* ([extract-ivars
|
||||
;; Unpacks a public, private, or override clause
|
||||
(lambda (kind can-rename? decls)
|
||||
(map
|
||||
(lambda (decl)
|
||||
(syntax-case decl ()
|
||||
[id (identifier? (syntax id))
|
||||
(list kind (syntax id) (syntax id) (syntax (void)))]
|
||||
[(id expr) (identifier? (syntax id))
|
||||
(list kind (syntax id) (syntax id) (syntax expr))]
|
||||
[(id) (and can-rename? (identifier? (syntax id)))
|
||||
(list kind (syntax id) (syntax id) (syntax (void)))]
|
||||
[((iid eid) expr) (and can-rename?
|
||||
(identifier? (syntax iid))
|
||||
(identifier? (syntax eid)))
|
||||
(list kind (syntax iid) (syntax eid) (syntax expr))]
|
||||
[else (se (format "bad ~a clause" kind) (syntax decl))]))
|
||||
(syntax->list decls)))]
|
||||
[body
|
||||
;; Make a list of normalized clause-like lists, e.g:
|
||||
;; (list (list 'public internal-id extenal-id expr) ...)
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (clause)
|
||||
(syntax-case clause (public override private rename inherit sequence)
|
||||
[(public decl ...)
|
||||
(extract-ivars 'public #t (syntax (decl ...)))]
|
||||
[(override decl ...)
|
||||
(extract-ivars 'override #t (syntax (decl ...)))]
|
||||
[(private decl ...)
|
||||
(extract-ivars 'private #f (syntax (decl ...)))]
|
||||
[(rename (iid eid) ...)
|
||||
(let ([iids (syntax->list (syntax (iid ...)))]
|
||||
[eids (syntax->list (syntax (eid ...)))])
|
||||
(for-each (lambda (s)
|
||||
(unless (identifier? s)
|
||||
(se "expected an identifier" s)))
|
||||
(append iids eids))
|
||||
(map (lambda (iid eid)
|
||||
(list 'rename iid eid))
|
||||
iids eids))]
|
||||
[(inherit id ...)
|
||||
(map
|
||||
(lambda (decl)
|
||||
(syntax-case decl ()
|
||||
[id (identifier? (syntax id))
|
||||
(list 'inherit (syntax id) (syntax id))]
|
||||
[(iid eid) (and (identifier? (syntax iid))
|
||||
(identifier? (syntax eid)))
|
||||
(list 'inherit (syntax iid) (syntax eid))]
|
||||
[else (se "bad inherit clause" decl)]))
|
||||
(syntax->list (syntax (id ...))))]
|
||||
[(sequence expr ...)
|
||||
(map
|
||||
(lambda (expr)
|
||||
(list 'sequence expr))
|
||||
(syntax->list (syntax (expr ...))))]
|
||||
[else (se "not a class clause" clause)]))
|
||||
(syntax->list (syntax (clauses ...)))))]
|
||||
[get-info (lambda (tags select)
|
||||
(let loop ([body body])
|
||||
(cond
|
||||
[(null? body) null]
|
||||
[(memq (caar body) tags)
|
||||
(cons (select (car body)) (loop (cdr body)))]
|
||||
[else (loop (cdr body))])))])
|
||||
;; Extract internal and external ids, and create xformed body:
|
||||
(let ([new-eids (get-info '(public) caddr)]
|
||||
[use-pre-eids (get-info '(rename) caddr)]
|
||||
[use-final-eids (get-info '(inherit) caddr)]
|
||||
[replace-eids (get-info '(override) caddr)]
|
||||
[inherited-ids (get-info '(inherit rename) cadr)]
|
||||
[public-ids (get-info '(public override) cadr)]
|
||||
[private-ids (get-info '(private) cadr)]
|
||||
[immutable-boxed-ids (append (get-info '(rename) cadr) ;; order matters!
|
||||
(get-info '(inherit) cadr))]
|
||||
[mutable-boxed-ids (append (get-info '(override) cadr) ;; order matters!
|
||||
(get-info '(public) cadr))])
|
||||
(let* ([define-eids (append replace-eids new-eids)]
|
||||
[define-iids (generate-temporaries define-eids)]
|
||||
[body-exprs
|
||||
(map
|
||||
;; Map each declaration clause to a set!:
|
||||
(lambda (clause)
|
||||
(if (eq? (car clause) 'sequence)
|
||||
(cadr clause)
|
||||
(with-syntax ([id (cadr clause)]
|
||||
[expr (cadddr clause)])
|
||||
(if (memq (car clause) '(public override))
|
||||
(let ([eid (caddr clause)])
|
||||
(with-syntax ([nid (let loop ([de define-eids]
|
||||
[di define-iids])
|
||||
(if (eq? eid (car de))
|
||||
(car di)
|
||||
(loop (cdr de) (cdr di))))])
|
||||
;; let sets name for expr:
|
||||
(syntax (set-box! nid (let ([id expr]) id)))))
|
||||
(syntax (set! id expr))))))
|
||||
(get-info '(public override private sequence) values))]
|
||||
[name (syntax-local-name)])
|
||||
;; Check for duplicates:
|
||||
(cond
|
||||
[(check-duplicate-identifier
|
||||
(append new-eids use-final-eids replace-eids))
|
||||
=> (lambda (name)
|
||||
(se "duplicate declaration of external name" name))]
|
||||
[(check-duplicate-identifier
|
||||
(append init-ids (if init-rest-id (list init-rest-id) null)
|
||||
public-ids inherited-ids private-ids))
|
||||
=> (lambda (name)
|
||||
(se "duplicate declaration of identifier" name))]
|
||||
[else (void)])
|
||||
;; ---------- build the result ----------
|
||||
;; References to non-private ivars are converted to box
|
||||
;; references.
|
||||
(with-syntax ([use-pre-eids use-pre-eids]
|
||||
[use-final-eids use-final-eids]
|
||||
[replace-eids replace-eids]
|
||||
[new-eids new-eids]
|
||||
[define-eids define-eids]
|
||||
[(define-iid ...) define-iids]
|
||||
[(immutable-box-id ...) (generate-temporaries immutable-boxed-ids)]
|
||||
[(mutable-box-id ...) (generate-temporaries mutable-boxed-ids)]
|
||||
[(immutable-boxed-id ...) immutable-boxed-ids]
|
||||
[(mutable-boxed-id ...) mutable-boxed-ids]
|
||||
[(private-id ...) private-ids]
|
||||
[body-exprs (if (null? body-exprs)
|
||||
(syntax ((void)))
|
||||
body-exprs)]
|
||||
[init (datum->syntax
|
||||
(if name
|
||||
(string->symbol (format "~a-init" name))
|
||||
'init)
|
||||
#f #f)]
|
||||
[name (datum->syntax name #f #f)])
|
||||
(with-syntax ([go
|
||||
;; Create a sequence of case-lambda
|
||||
;; clauses, to implement init variable defaults:
|
||||
(let loop ([vars-so-far null]
|
||||
[vars-w/def-so-far null]
|
||||
[def-so-far null]
|
||||
[init-ids init-ids]
|
||||
[init-defs init-defs])
|
||||
(cond
|
||||
[(null? init-ids)
|
||||
(with-syntax ([(var ...) (reverse vars-so-far)]
|
||||
[(maybe-inited ...) (generate-temporaries vars-w/def-so-far)]
|
||||
[(dvar ...) (reverse vars-w/def-so-far)]
|
||||
[(def ...) (reverse def-so-far)]
|
||||
[rest-id (if init-rest-id
|
||||
init-rest-id
|
||||
null)])
|
||||
(syntax
|
||||
([(var ... maybe-inited ... . rest-id)
|
||||
(let ([dvar undefined] ...)
|
||||
(set! dvar (if (eq? maybe-inited needs-init)
|
||||
def
|
||||
maybe-inited)) ...
|
||||
.
|
||||
body-exprs)])))]
|
||||
[else
|
||||
(with-syntax ([rest (loop (if (car init-defs)
|
||||
vars-so-far
|
||||
(cons (car init-ids) vars-so-far))
|
||||
(if (car init-defs)
|
||||
(cons (car init-ids) vars-w/def-so-far)
|
||||
null)
|
||||
(if (car init-defs)
|
||||
(cons (car init-defs) def-so-far)
|
||||
null)
|
||||
(cdr init-ids)
|
||||
(cdr init-defs))])
|
||||
(if (car init-defs)
|
||||
(with-syntax ([(var ...) (reverse vars-so-far)]
|
||||
[(wd-var ...) (reverse vars-w/def-so-far)])
|
||||
(syntax ([(var ... wd-var ...) (init var ... wd-var ... needs-init)]
|
||||
. rest)))
|
||||
(syntax rest)))]))]
|
||||
[go-arity (datum->syntax
|
||||
(let ([req (let loop ([l init-defs][c 0])
|
||||
(if (or (null? l) (car l))
|
||||
c
|
||||
(loop (cdr l) (add1 c))))]
|
||||
[cnt (length init-ids)])
|
||||
(cond
|
||||
[init-rest-id
|
||||
(box req)]
|
||||
[(< req cnt)
|
||||
(let loop ([req req])
|
||||
(if (= req cnt)
|
||||
(list req)
|
||||
(cons req (loop (add1 req)))))]
|
||||
[else req]))
|
||||
#f #f)])
|
||||
;; Assemble the result as a `compose-class-info' call,
|
||||
;; which does all the run-time checks, and knows how
|
||||
;; to allocate objects and pass boxes to the init
|
||||
;; function.
|
||||
(syntax/loc
|
||||
stx
|
||||
(compose-class
|
||||
'name
|
||||
super-expr
|
||||
(list interface-expr ...)
|
||||
'use-pre-eids ;; rename
|
||||
'use-final-eids ;; inherit
|
||||
'replace-eids ;; override
|
||||
'new-eids ;; public
|
||||
(lambda (this-id super-init-id
|
||||
define-iid ... ;; override, public
|
||||
immutable-box-id ... ;; rename, inherit
|
||||
mutable-box-id ...) ;; override, public
|
||||
(let-syntax ([immutable-boxed-id
|
||||
(set!-expander
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set!)
|
||||
[vr (identifier? (syntax vr))
|
||||
(syntax (unbox immutable-box-id))]
|
||||
[(set! vr val)
|
||||
(raise-syntax-error
|
||||
'class*/names
|
||||
"cannot mutate an inherit or rename variable"
|
||||
stx)]
|
||||
[(vr . args) (syntax ((unbox immutable-box-id) . args))])))]
|
||||
...
|
||||
[mutable-boxed-id
|
||||
(set!-expander
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set!)
|
||||
[vr (identifier? (syntax vr))
|
||||
(syntax (unbox mutable-box-id))]
|
||||
[(set! vr val)
|
||||
(syntax
|
||||
(set-box! mutable-box-id
|
||||
;; let vr gives val the right name
|
||||
(let ([vr val]) vr)))]
|
||||
[(vr . args) (syntax ((unbox mutable-box-id) . args))])))]
|
||||
...)
|
||||
(let ([private-id undefined] ...)
|
||||
(letrec ([init (case-lambda . go)])
|
||||
init))))
|
||||
'go-arity)))))))))]
|
||||
;; Error cases
|
||||
;; --
|
||||
[(_ bad-this-super
|
||||
super-expr
|
||||
(interface-expr ...)
|
||||
init-vars
|
||||
clauses ...)
|
||||
(raise-syntax-error
|
||||
'class*/names
|
||||
"bad this and super bindings"
|
||||
(syntax bad-this-super)
|
||||
stx)]
|
||||
;; --
|
||||
[(_ this-super
|
||||
super-expr
|
||||
bad-interface-seq
|
||||
init-vars
|
||||
clauses ...)
|
||||
(raise-syntax-error
|
||||
'class*/names
|
||||
"expected sequence of interface expressions"
|
||||
(syntax bad-interface-seq)
|
||||
stx)]
|
||||
;;
|
||||
[(_ this-super
|
||||
super-expr
|
||||
interface-seq)
|
||||
(raise-syntax-error
|
||||
'class*/names
|
||||
"missing initialization arguments"
|
||||
(syntax bad-this-super)
|
||||
stx)]
|
||||
[(_ this-super
|
||||
super-expr)
|
||||
(raise-syntax-error
|
||||
'class*/names
|
||||
"missing interface expressions"
|
||||
(syntax bad-this-super)
|
||||
stx)]
|
||||
[(_ this-super)
|
||||
(raise-syntax-error
|
||||
'class*/names
|
||||
"missing this and super-init bindings"
|
||||
(syntax bad-this-super)
|
||||
stx)])))
|
||||
|
||||
(define-syntax class*
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ super-expr
|
||||
(interface-expr ...)
|
||||
init-vars
|
||||
clauses ...)
|
||||
(with-syntax ([this (datum->syntax 'this stx (stx-car stx))]
|
||||
[super-init (datum->syntax 'super-init stx (stx-car stx))])
|
||||
(syntax/loc
|
||||
stx
|
||||
(class*/names (this super-init)
|
||||
super-expr
|
||||
(interface-expr ...)
|
||||
init-vars
|
||||
clauses ...)))])))
|
||||
|
||||
(define-syntax class
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ super-expr
|
||||
init-vars
|
||||
clauses ...)
|
||||
(with-syntax ([class* (datum->syntax 'class* stx (stx-car stx))])
|
||||
(syntax/loc stx (class* super-expr () init-vars clauses ...)))])))
|
||||
|
||||
(define-syntax interface
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (interface-expr ...) var ...)
|
||||
(let ([vars (syntax->list (syntax (var ...)))]
|
||||
[name (syntax-local-name)])
|
||||
(for-each
|
||||
(lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error 'interface
|
||||
"not an identifier"
|
||||
stx
|
||||
v)))
|
||||
vars)
|
||||
(let ([dup (check-duplicate-identifier vars)])
|
||||
(when dup
|
||||
(raise-syntax-error 'interface
|
||||
"duplicate name"
|
||||
stx
|
||||
dup)))
|
||||
(with-syntax ([name (datum->syntax name #f #f)])
|
||||
(syntax/loc
|
||||
stx
|
||||
(compose-interface
|
||||
'name
|
||||
(list interface-expr ...)
|
||||
'(var ...)))))])))
|
||||
|
||||
(export-indirect compose-class
|
||||
compose-interface
|
||||
undefined needs-init)
|
||||
|
||||
(export class class* class*/names
|
||||
interface
|
||||
make-object object? is-a? subclass? class? interface?
|
||||
class->interface object-interface
|
||||
implementation? interface-extension?
|
||||
ivar-in-interface? interface->ivar-names
|
||||
class-initialization-arity
|
||||
ivar send make-generic
|
||||
ivar/proc make-generic/proc
|
||||
object% ;; object<%>
|
||||
exn:object? struct:exn:object make-exn:object))
|
||||
594
collects/mzlib/unit.ss
Normal file
594
collects/mzlib/unit.ss
Normal file
|
|
@ -0,0 +1,594 @@
|
|||
183
|
||||
;; Unit system
|
||||
|
||||
(module unit mzscheme
|
||||
(import-for-syntax mzscheme)
|
||||
|
||||
(define undefined (letrec ([x x]) x))
|
||||
|
||||
(define-struct unit (num-imports exports go))
|
||||
(define-struct (exn:unit struct:exn) ())
|
||||
|
||||
(define-syntax unit
|
||||
(lambda (stx)
|
||||
(syntax-case stx (import export)
|
||||
[(_ (import ivar ...)
|
||||
(export evar ...)
|
||||
defn&expr ...)
|
||||
(let ([check-id (lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"import is not an identifier"
|
||||
stx
|
||||
v)))]
|
||||
[check-renamed-id
|
||||
(lambda (v)
|
||||
(syntax-case v ()
|
||||
[id (identifier? (syntax id)) 'ok]
|
||||
[(lid eid) (and (identifier? (syntax lid))
|
||||
(identifier? (syntax eid))) 'ok]
|
||||
[else (raise-syntax-error
|
||||
'unit
|
||||
"export is not an identifier or renamed identifier"
|
||||
stx
|
||||
v)]))]
|
||||
[ivars (syntax->list (syntax (ivar ...)))]
|
||||
[evars (syntax->list (syntax (evar ...)))])
|
||||
(for-each check-id ivars)
|
||||
(for-each check-renamed-id evars)
|
||||
|
||||
;; Get import/export declared names:
|
||||
(let* ([exported-names
|
||||
(map (lambda (v)
|
||||
(syntax-case v ()
|
||||
[(lid eid) (syntax lid)]
|
||||
[id (syntax id)]))
|
||||
evars)]
|
||||
[extnames (map (lambda (v)
|
||||
(syntax-case v ()
|
||||
[(lid eid) (syntax eid)]
|
||||
[id (syntax id)]))
|
||||
evars)]
|
||||
[imported-names ivars]
|
||||
[declared-names (append imported-names exported-names)])
|
||||
;; Check that all exports are distinct (as symbols)
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each (lambda (name)
|
||||
(when (hash-table-get ht (syntax-e name) (lambda () #f))
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"duplicate export"
|
||||
stx
|
||||
name))
|
||||
(hash-table-put! ht (syntax-e name) #t))
|
||||
extnames))
|
||||
|
||||
;; Expand all body expressions
|
||||
;; so that all definitions are exposed.
|
||||
(letrec ([expand-all
|
||||
(lambda (defns&exprs)
|
||||
(let ([expanded
|
||||
(map
|
||||
(lambda (defn-or-expr)
|
||||
(local-expand
|
||||
defn-or-expr
|
||||
(list*
|
||||
(quote-syntax begin)
|
||||
(quote-syntax define-values)
|
||||
(quote-syntax define-syntax)
|
||||
(quote-syntax set!)
|
||||
(quote-syntax #%app)
|
||||
declared-names)))
|
||||
defns&exprs)])
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (defn-or-expr)
|
||||
(syntax-case defn-or-expr (begin)
|
||||
[(begin . l)
|
||||
(let ([l (syntax->list (syntax l))])
|
||||
(unless l
|
||||
(raise-syntax-error
|
||||
'begin
|
||||
"bad syntax (illegal use of `.')"
|
||||
stx
|
||||
defn-or-expr))
|
||||
(expand-all l))]
|
||||
[else (list defn-or-expr)]))
|
||||
expanded))))])
|
||||
(let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
|
||||
;; Get all the defined names
|
||||
(let ([all-defined-names
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (defn-or-expr)
|
||||
(syntax-case defn-or-expr (define-values define-syntax)
|
||||
[(define-values (id ...) expr)
|
||||
(let ([l (syntax->list (syntax (id ...)))])
|
||||
(for-each (lambda (i)
|
||||
(unless (identifier? i)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"not an identifier in definition"
|
||||
stx
|
||||
i)))
|
||||
l)
|
||||
l)]
|
||||
[(define-values . l)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"bad definition form"
|
||||
stx
|
||||
defn-or-expr)]
|
||||
[(define-syntax . l)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"misplaced syntax definition"
|
||||
stx
|
||||
defn-or-expr)]
|
||||
[else null]))
|
||||
all-expanded))])
|
||||
;; Check that all defined names are distinct:
|
||||
(let ([name (check-duplicate-identifier
|
||||
(append imported-names all-defined-names))])
|
||||
(when name
|
||||
(raise-syntax-error
|
||||
'syntax
|
||||
"variable imported and/or defined twice"
|
||||
stx
|
||||
name)))
|
||||
;; Compute defined but not exported:
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each
|
||||
(lambda (name)
|
||||
(let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
|
||||
(hash-table-put! ht (syntax-e name) (cons name l))))
|
||||
exported-names)
|
||||
(let ([internal-names
|
||||
(let loop ([l all-defined-names])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(let ([v (hash-table-get ht (syntax-e (car l)) (lambda () null))])
|
||||
(ormap (lambda (i) (bound-identifier=? i (car l))) v))
|
||||
(loop (cdr l))]
|
||||
[else (cons (car l) (loop (cdr l)))]))])
|
||||
;; Generate names for import/export boxes, etc:
|
||||
(with-syntax ([(iloc ...) (generate-temporaries (syntax (ivar ...)))]
|
||||
[(eloc ...) (generate-temporaries evars)]
|
||||
[(extname ...) extnames]
|
||||
[(expname ...) exported-names]
|
||||
[(intname ...) internal-names])
|
||||
;; Change all definitions to set!s. Convert evars to set-box!,
|
||||
;; because set! on exported variables is not allowed.
|
||||
(with-syntax ([(defn&expr ...) (let ([elocs (syntax->list (syntax (eloc ...)))])
|
||||
(map (lambda (defn-or-expr)
|
||||
(syntax-case defn-or-expr (define-values)
|
||||
[(define-values ids expr)
|
||||
(let* ([ids (syntax->list (syntax ids))])
|
||||
(if (null? ids)
|
||||
(syntax/loc defn-or-expr (set!-values ids expr))
|
||||
(let ([do-one
|
||||
(lambda (id tmp name)
|
||||
(let loop ([evars exported-names]
|
||||
[elocs elocs])
|
||||
(cond
|
||||
[(null? evars)
|
||||
;; not an exported id
|
||||
(with-syntax ([id id][tmp tmp])
|
||||
(syntax/loc
|
||||
defn-or-expr
|
||||
(set! id tmp)))]
|
||||
[(bound-identifier=? (car evars) id)
|
||||
;; set! exported id:
|
||||
(with-syntax ([loc (car elocs)]
|
||||
[tmp
|
||||
(if name
|
||||
(with-syntax ([tmp tmp]
|
||||
[name name])
|
||||
(syntax (let ([name tmp])
|
||||
name)))
|
||||
tmp)])
|
||||
(syntax/loc
|
||||
defn-or-expr
|
||||
(set-box! loc tmp)))]
|
||||
[else (loop (cdr evars) (cdr elocs))])))])
|
||||
(if (null? (cdr ids))
|
||||
(do-one (car ids) (syntax expr) (car ids))
|
||||
(let ([tmps (generate-temporaries ids)])
|
||||
(with-syntax ([(tmp ...) tmps]
|
||||
[(set ...) (map (lambda (id tmp)
|
||||
(do-one id tmp #f))
|
||||
ids tmps)])
|
||||
(syntax/loc
|
||||
defn-or-expr
|
||||
(let-values ([(tmp ...) expr])
|
||||
set ...))))))))]
|
||||
[else defn-or-expr]))
|
||||
all-expanded))])
|
||||
;; Build up set! redirection chain:
|
||||
(with-syntax ([redirected
|
||||
(let loop ([l (syntax->list (syntax ((ivar iloc) ...
|
||||
(expname eloc) ...)))])
|
||||
(if (null? l)
|
||||
(let ([body (syntax (defn&expr ...))])
|
||||
(if (null? (syntax-e body))
|
||||
(syntax ((void)))
|
||||
body))
|
||||
(with-syntax ([rest (loop (cdr l))]
|
||||
[(var loc) (car l)])
|
||||
(syntax
|
||||
((letrec-syntax ([var (set!-expander
|
||||
(lambda (sstx)
|
||||
(syntax-case sstx (set!)
|
||||
[vr (identifier? (syntax vr)) (syntax (unbox loc))]
|
||||
[(set! vr val)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"cannot set! imported or exported variables"
|
||||
sstx)]
|
||||
[(vr . args) (syntax ((unbox loc) . args))])))])
|
||||
. rest))))))]
|
||||
[num-imports (datum->syntax (length (syntax->list (syntax (iloc ...))))
|
||||
#f (quote-syntax here))])
|
||||
(syntax/loc
|
||||
stx
|
||||
(make-unit
|
||||
num-imports
|
||||
(list (quote extname) ...)
|
||||
(lambda ()
|
||||
(let ([eloc (box undefined)] ...)
|
||||
(list (vector eloc ...)
|
||||
(lambda (iloc ...)
|
||||
(let ([intname undefined] ...)
|
||||
. redirected)))))))))))))))))])))
|
||||
|
||||
(define (check-expected-interface tag unit num-imports exports)
|
||||
(unless (unit? unit)
|
||||
(raise
|
||||
(make-exn:unit
|
||||
(format "compound-unit: result of expression for tag ~s not a unit: ~e" tag unit)
|
||||
(current-continuation-marks))))
|
||||
(unless (= num-imports (unit-num-imports unit))
|
||||
(raise
|
||||
(make-exn:unit
|
||||
(format "compound-unit: unit for tag ~s expects ~a imports, given ~a"
|
||||
tag
|
||||
(unit-num-imports unit)
|
||||
num-imports)
|
||||
(current-continuation-marks))))
|
||||
(list->vector
|
||||
(map (lambda (ex)
|
||||
(let loop ([l (unit-exports unit)][i 0])
|
||||
(cond
|
||||
[(null? l)
|
||||
(raise
|
||||
(make-exn:unit
|
||||
(format "compount-unit: unit for tag ~s has no ~s export"
|
||||
tag ex)
|
||||
(current-continuation-marks)))]
|
||||
[(eq? (car l) ex)
|
||||
i]
|
||||
[else (loop (cdr l) (add1 i))])))
|
||||
exports)))
|
||||
|
||||
(define-syntax compound-unit
|
||||
(lambda (stx)
|
||||
(syntax-case stx (import export link)
|
||||
[(_ (import ivar ...)
|
||||
(link [tag (unit-expr linkage ...)] ...)
|
||||
(export exportage ...))
|
||||
(let ([check-id (lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"import is not an identifier"
|
||||
stx
|
||||
v)))]
|
||||
[check-tag (lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"tag is not an identifier"
|
||||
stx
|
||||
v)))]
|
||||
[check-linkage (lambda (v)
|
||||
(syntax-case v ()
|
||||
[id (identifier? (syntax id)) #t]
|
||||
[(tag id ...)
|
||||
(for-each (lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"non-identifier in linkage"
|
||||
stx
|
||||
v)))
|
||||
(syntax->list v))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"ill-formed linkage"
|
||||
stx
|
||||
v)]))]
|
||||
[check-exportage (lambda (v)
|
||||
(syntax-case v ()
|
||||
[(tag ex ...)
|
||||
(begin
|
||||
(unless (identifier? (syntax tag))
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"export tag is not an identifier"
|
||||
stx
|
||||
(syntax tag)))
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(syntax-case e ()
|
||||
[id (identifier? (syntax id)) #t]
|
||||
[(iid eid)
|
||||
(begin
|
||||
(unless (identifier? (syntax iid))
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"export internal name is not an identifier"
|
||||
stx
|
||||
(syntax iid)))
|
||||
(unless (identifier? (syntax eid))
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"export internal name is not an identifier"
|
||||
stx
|
||||
(syntax eid))))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
(format "ill-formed export with tag ~a" (syntax-e (syntax tag)))
|
||||
stx
|
||||
e)]))
|
||||
(syntax->list (syntax (ex ...)))))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"ill-formed export"
|
||||
stx
|
||||
v)]))]
|
||||
[imports (syntax->list (syntax (ivar ...)))]
|
||||
[tags (syntax->list (syntax (tag ...)))]
|
||||
[linkages (map syntax->list (syntax->list (syntax ((linkage ...) ...))))]
|
||||
[exports (syntax->list (syntax (exportage ...)))])
|
||||
;; Syntax checks:
|
||||
(for-each check-id imports)
|
||||
(for-each check-tag tags)
|
||||
(for-each (lambda (l) (for-each check-linkage l)) linkages)
|
||||
(for-each check-exportage exports)
|
||||
;; Check for duplicate imports
|
||||
(let ([dup (check-duplicate-identifier imports)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"duplicate import"
|
||||
stx
|
||||
dup)))
|
||||
;; Check referenced imports and tags
|
||||
(let ([check-linkage-refs (lambda (v)
|
||||
(syntax-case v ()
|
||||
[(tag . exs)
|
||||
(unless (ormap (lambda (t)
|
||||
(bound-identifier=? t (syntax tag)))
|
||||
tags)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"linkage tag is not bound"
|
||||
stx
|
||||
(syntax tag)))]
|
||||
[id (unless (ormap (lambda (i)
|
||||
(bound-identifier=? i (syntax id)))
|
||||
imports)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"no imported identified for linkage"
|
||||
stx
|
||||
(syntax id)))]))]
|
||||
[check-export-refs (lambda (v)
|
||||
(syntax-case v ()
|
||||
[(tag . r)
|
||||
(unless (ormap (lambda (t)
|
||||
(bound-identifier=? t (syntax tag)))
|
||||
tags)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"export tag is not bound"
|
||||
stx
|
||||
(syntax tag)))]))])
|
||||
(for-each (lambda (l) (for-each check-linkage-refs l))
|
||||
linkages)
|
||||
(for-each check-export-refs exports)
|
||||
;; Get all export names, and check for duplicates
|
||||
(let ([export-names
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (v)
|
||||
(syntax-case v ()
|
||||
[(tag . exs)
|
||||
(map
|
||||
(lambda (e)
|
||||
(syntax-case e ()
|
||||
[(iid eid) (syntax eid)]
|
||||
[id e]))
|
||||
(syntax->list (syntax exs)))]))
|
||||
exports))])
|
||||
(let ([dup (check-duplicate-identifier exports)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
"duplicate export"
|
||||
stx
|
||||
dup)))
|
||||
|
||||
(let ([constituents (generate-temporaries tags)]
|
||||
[unit-export-positionss (generate-temporaries tags)]
|
||||
[unit-setups (generate-temporaries tags)]
|
||||
[unit-export-lists
|
||||
;; For each tag, get all expected exports
|
||||
(let* ([hts (map (lambda (x) (make-hash-table)) tags)]
|
||||
[get-add-name
|
||||
(lambda (tag)
|
||||
(ormap (lambda (t ht)
|
||||
(and (bound-identifier=? t tag)
|
||||
(lambda (name)
|
||||
(hash-table-put! ht (syntax-e name) name))))
|
||||
tags hts))])
|
||||
;; Walk though linkages
|
||||
(for-each
|
||||
(lambda (linkage-list)
|
||||
(for-each
|
||||
(lambda (linkage)
|
||||
(syntax-case linkage ()
|
||||
[(tag . ids)
|
||||
(let ([add-name (get-add-name (syntax tag))])
|
||||
(for-each add-name (syntax->list (syntax ids))))]
|
||||
[else (void)]))
|
||||
linkage-list))
|
||||
linkages)
|
||||
;; Walk through exports
|
||||
(for-each
|
||||
(lambda (v)
|
||||
(syntax-case v ()
|
||||
[(tag . exs)
|
||||
(let ([add-name (get-add-name (syntax tag))])
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(syntax-case e ()
|
||||
[(iid eid) (add-name (syntax iid))]
|
||||
[id (add-name (syntax id))]))
|
||||
(syntax->list (syntax exs))))]))
|
||||
exports)
|
||||
;; Extract names from hash tables
|
||||
(map (lambda (ht)
|
||||
(hash-table-map ht (lambda (k v) v)))
|
||||
hts))])
|
||||
;; Map exports to imports and indices based on expected unit exports
|
||||
(let ([map-tag (lambda (t l)
|
||||
(let loop ([tags tags][l l])
|
||||
(if (bound-identifier=? (car tags) t)
|
||||
(car l)
|
||||
(loop (cdr tags) (cdr l)))))]
|
||||
[unit-export-hts (map (lambda (export-list)
|
||||
(let ([ht (make-hash-table)])
|
||||
(let loop ([l export-list][p 0])
|
||||
(unless (null? l)
|
||||
(hash-table-put! ht (syntax-e (car l)) p)
|
||||
(loop (cdr l) (add1 p))))
|
||||
ht))
|
||||
unit-export-lists)])
|
||||
(let ([make-mapping
|
||||
(lambda (v)
|
||||
(syntax-case v ()
|
||||
[(tag . exs)
|
||||
(let ([ex-poss (map-tag (syntax tag)
|
||||
unit-export-positionss)]
|
||||
[setup (map-tag (syntax tag)
|
||||
unit-setups)]
|
||||
[ht (map-tag (syntax tag)
|
||||
unit-export-hts)])
|
||||
(map
|
||||
(lambda (e)
|
||||
(let ([pos (hash-table-get
|
||||
ht
|
||||
(syntax-e
|
||||
(syntax-case e ()
|
||||
[(iid eid) (syntax id)]
|
||||
[id e])))])
|
||||
(with-syntax ([ex-poss ex-poss]
|
||||
[setup setup]
|
||||
[pos (datum->syntax
|
||||
pos
|
||||
#f
|
||||
(quote-syntax here))])
|
||||
(syntax
|
||||
(vector-ref (car setup)
|
||||
(vector-ref ex-poss pos))))))
|
||||
(syntax->list (syntax exs))))]
|
||||
[import (list v)]))])
|
||||
(let ([export-mapping (apply append (map make-mapping exports))]
|
||||
[import-mappings (map (lambda (linkage-list)
|
||||
(apply append
|
||||
(map make-mapping linkage-list)))
|
||||
linkages)])
|
||||
(with-syntax ([(constituent ...) constituents]
|
||||
[(unit-export-positions ...) unit-export-positionss]
|
||||
[(unit-setup ...) unit-setups]
|
||||
[(unit-export-list ...) unit-export-lists]
|
||||
[(import-mapping ...) import-mappings]
|
||||
[(unit-import-count ...)
|
||||
(map (lambda (l)
|
||||
(datum->syntax (apply
|
||||
+
|
||||
(map (lambda (v)
|
||||
(if (identifier? v)
|
||||
1
|
||||
(length (cdr (syntax->list v)))))
|
||||
l))
|
||||
#f
|
||||
(quote-syntax here)))
|
||||
linkages)]
|
||||
[num-imports (datum->syntax (length imports)
|
||||
#f (quote-syntax here))]
|
||||
[export-names export-names]
|
||||
[export-mapping export-mapping])
|
||||
(syntax/loc
|
||||
stx
|
||||
(let ([constituent unit-expr]
|
||||
...)
|
||||
(let ([unit-export-positions
|
||||
(check-expected-interface
|
||||
'tag
|
||||
constituent
|
||||
unit-import-count
|
||||
'unit-export-list)]
|
||||
...)
|
||||
(make-unit
|
||||
num-imports
|
||||
(quote export-names)
|
||||
(lambda ()
|
||||
(let ([unit-setup ((unit-go constituent))] ...)
|
||||
(list (vector . export-mapping)
|
||||
(lambda (ivar ...)
|
||||
((list-ref unit-setup 1) . import-mapping)
|
||||
...))))))))))))))))])))
|
||||
|
||||
(define (check-unit u n)
|
||||
(unless (unit? u)
|
||||
(raise
|
||||
(make-exn:unit
|
||||
(format "invoke-unit: result of unit expression was not a unit: ~e" u)
|
||||
(current-continuation-marks))))
|
||||
(unless (= (unit-num-imports u) n)
|
||||
(raise
|
||||
(make-exn:unit
|
||||
(format "invoke-unit: expected a unit with ~a imports, given one with ~a imports"
|
||||
n (unit-num-imports u))
|
||||
(current-continuation-marks)))))
|
||||
|
||||
(define-syntax invoke-unit
|
||||
(lambda (stx)
|
||||
(syntax-case stx (import export)
|
||||
[(_ unit-expr expr ...)
|
||||
(let ([exprs (syntax (expr ...))])
|
||||
(with-syntax ([(bx ...) (generate-temporaries (syntax (expr ...)))]
|
||||
[num (datum->syntax (length (syntax->list exprs))
|
||||
#f
|
||||
(quote-syntax here))])
|
||||
(syntax/loc
|
||||
stx
|
||||
(let ([u unit-expr])
|
||||
(check-unit u num)
|
||||
(let ([bx (box expr)] ...)
|
||||
((list-ref ((unit-go u)) 1)
|
||||
bx ...))))))])))
|
||||
|
||||
(export-indirect make-unit check-unit undefined unit-go
|
||||
check-expected-interface)
|
||||
(export unit compound-unit invoke-unit unit?
|
||||
exn:unit? struct:exn:unit make-exn:unit))
|
||||
Loading…
Reference in New Issue
Block a user