From d1d3239767fd82aa63a7e3c9cb906daf063f2a32 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 Jan 2001 21:40:58 +0000 Subject: [PATCH] . original commit: b8c8af76a2ee47e8d207f165842a6bef12b9c3aa --- collects/mzlib/class.ss | 828 ++++++++++++++++++++++++++++++++++++++++ collects/mzlib/unit.ss | 594 ++++++++++++++++++++++++++++ 2 files changed, 1422 insertions(+) create mode 100644 collects/mzlib/class.ss create mode 100644 collects/mzlib/unit.ss diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss new file mode 100644 index 0000000..37c1163 --- /dev/null +++ b/collects/mzlib/class.ss @@ -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)) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss new file mode 100644 index 0000000..ba13000 --- /dev/null +++ b/collects/mzlib/unit.ss @@ -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))