diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index 390efc8..6a64375 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -1976,7 +1976,7 @@ (define undefined (letrec ([x x]) x)) - (define-struct (exn:object struct:exn) () insp) + (define-struct (exn:object exn) () insp) (define (obj-error where . msg) (raise diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss index a248de2..1f0075d 100644 --- a/collects/mzlib/match.ss +++ b/collects/mzlib/match.ss @@ -109,7 +109,7 @@ (define match:version "Version 1.10mz, Feb 5, 1996") - (define-struct (exn:misc:match struct:exn:misc) (value)) + (define-struct (exn:misc:match exn:misc) (value)) (define match:error (case-lambda diff --git a/collects/mzlib/private/sigmatch.ss b/collects/mzlib/private/sigmatch.ss index 058a845..068c4f8 100644 --- a/collects/mzlib/private/sigmatch.ss +++ b/collects/mzlib/private/sigmatch.ss @@ -4,7 +4,8 @@ (require "../unit.ss") (define (hash-sig src-sig table) - (and (vector? src-sig) + (and (pair? src-sig) + (vector? (car src-sig)) (andmap (lambda (s) (cond @@ -22,7 +23,7 @@ (hash-table-put! table name t) (hash-sig (cdr s) t))))] [else #f])) - (vector->list src-sig)))) + (vector->list (car src-sig))))) (define (sig-path-name name path) (let loop ([s (symbol->string name)] @@ -33,7 +34,7 @@ (cdr path))))) (define (check-sig-match table sig path exact? who src-context dest-context) - (and (vector? sig) + (and (vector? (car sig)) (andmap (lambda (s) (cond @@ -95,7 +96,7 @@ (check-sig-match v (cdr s) (cons (car s) path) exact? who src-context dest-context))))] [else #f])) - (vector->list sig)) + (vector->list (car sig))) (or (not exact?) (hash-table-for-each table diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index 1472069..b992f72 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -1,6 +1,7 @@ (module sigutil mzscheme - ;; Used by signedunit.ss + ;; Used by unitsig.ss + ;; (needs an overhaul, too) (require (lib "stx.ss" "syntax")) @@ -8,10 +9,13 @@ (require "../unit.ss") (require "../list.ss") - (define-struct signature (name ; sym - src ; sym - elems)) ; list of syms and signatures - (define-struct parse-unit (imports renames vars body)) + (define-struct signature (name ; sym + src ; sym + elems ; list of syms and signatures + structs)) ; list of struct-infos + (define-struct parse-unit (imports renames vars stxes body stx-checks)) + + (define-struct struct-info (name super-name names)) (define-struct sigdef (content interned)) (define (make-sig x) (make-sigdef x #f)) @@ -51,23 +55,28 @@ (lambda (sig name) (make-signature name (signature-src sig) - (signature-elems sig)))) + (signature-elems sig) + (signature-structs sig)))) (define intern-signature - (lambda (name desc error) + (lambda (name desc) (make-signature name name - (if (vector? desc) - (map - (lambda (elem) - (cond - [(symbol? elem) elem] - [(and (pair? elem) (symbol? (car elem))) - (intern-signature (car elem) (cdr elem) error)] - [else (error)])) - (vector->list desc)) - (error))))) + (map + (lambda (elem) + (cond + [(symbol? elem) elem] + [(and (pair? elem) (symbol? (car elem))) + (intern-signature (car elem) (cdr elem))] + [else (error)])) + (vector->list (car desc))) + (map + (lambda (elem) + (make-struct-info (vector-ref elem 0) + (vector-ref elem 1) + (cddr (vector->list elem)))) + (vector->list (cdr desc)))))) (define get-sig (lambda (who expr name sigid) @@ -83,9 +92,7 @@ (unless (sigdef? v) (not-a-sig-error who expr sigid)) (unless (sigdef-interned v) - (set-sigdef-interned! v (intern-signature (syntax-e sigid) (sigdef-content v) - (lambda () - (not-a-sig-error who expr sigid))))) + (set-sigdef-interned! v (intern-signature (syntax-e sigid) (sigdef-content v)))) (let ([s (sigdef-interned v)]) (if name (rename-signature s (stx->sym name)) @@ -111,9 +118,9 @@ (datum->syntax-object name-stx (string->symbol s) #f)) (append (list + (+ "struct:" name) (+ "make-" name) - (+ name "?") - (+ "struct:" name)) + (+ name "?")) (if omit-sel? null (map @@ -129,107 +136,128 @@ (define parse-signature (lambda (who expr name body) - (let ([elems - (let loop ([body body]) - (syntax-case body () - [() null] - [(something . rest) - (append - (syntax-case (syntax something) () - [: - (literal? :) - (syntax-error who expr - "misplaced `:'" - (syntax something))] - [id - (identifier? (syntax id)) - (list (syntax id))] - [(struct name (field ...) omission ...) - (literal? struct) - (let ([name (syntax name)] - [fields (syntax->list (syntax (field ...)))] - [omissions (syntax->list (syntax (omission ...)))]) - (unless (identifier? name) - (syntax-error who expr - "struct name is not an identifier" - name)) - (for-each - (lambda (fld) - (unless (identifier? fld) - (syntax-error who expr - "field name is not an identifier" - fld))) - fields) - (let-values ([(omit-names - omit-setters? - omit-selectors?) - (let loop ([omissions omissions] - [names null] - [no-set? #f] - [no-sel? #f]) - (if (null? omissions) - (values names no-set? no-sel?) - (let ([rest (cdr omissions)]) - (syntax-case (car omissions) (-selectors - -setters - -) - [-selectors - (loop rest names #t no-sel?)] - [-setters - (loop rest names no-set? #t)] - [(- name) - (identifier? (syntax name)) - (loop rest (cons (syntax name) names) - no-set? no-sel?)] - [else - (syntax-error who expr - "bad struct omission" - (car omissions))]))))]) - (letrec ([names (build-struct-names - name fields - omit-selectors? omit-setters?)] - [filter - (lambda (names) - (cond - [(null? names) null] - [(ormap (lambda (x) (eq? (syntax-e (car names)) - (syntax-e x))) - omit-names) - (filter (cdr names))] - [else (cons (car names) (filter (cdr names)))]))]) - (if (null? omit-names) - names - (filter names)))))] - [(struct . _) - (literal? struct) - (syntax-error who expr - "bad `struct' clause form" - (syntax something))] - [(unit name : sig) - (and (literal? unit) - (identifier? (syntax name))) - (let ([s (get-sig who expr (syntax name) (syntax sig))]) - (list s))] - [(unit . _) - (literal? unit) - (syntax-error who expr - "bad `unit' clause form" - (syntax something))] - [(open sig) - (literal? open) - (let ([s (get-sig who expr #f (syntax sig))]) - (signature-elems s))] - [(open . _) - (literal? open) - (syntax-error who expr - "bad `open' clause form" - (syntax something))] - [else - (syntax-error who expr "improper signature clause type" - (syntax something))]) - (loop (syntax rest)))] - [_else (syntax-error who expr "ill-formed signature" - body)]))]) + (let-values ([(elems struct-infos) + (let loop ([body body][accum null][struct-accum null]) + (syntax-case body () + [() (values (reverse! accum) (reverse! struct-accum))] + [(something . rest) + (syntax-case (syntax something) () + [: + (literal? :) + (syntax-error who expr + "misplaced `:'" + (syntax something))] + [id + (identifier? (syntax id)) + (loop + (syntax rest) + (cons (syntax id) accum) + struct-accum)] + [(struct name (field ...) omission ...) + (literal? struct) + (let ([name (syntax name)] + [fields (syntax->list (syntax (field ...)))] + [omissions (syntax->list (syntax (omission ...)))]) + (unless (or (identifier? name) + (syntax-case name () + [(name super) + (and (identifier? (syntax name)) + (identifier? (syntax super)))] + [_else #f])) + (syntax-error who expr + "struct name is not an identifier or a parenthesized name--super sequence of identifiers" + name)) + (for-each + (lambda (fld) + (unless (identifier? fld) + (syntax-error who expr + "field name is not an identifier" + fld))) + fields) + (let-values ([(omit-names + omit-setters? + omit-selectors?) + (let loop ([omissions omissions] + [names null] + [no-set? #f] + [no-sel? #f]) + (if (null? omissions) + (values names no-set? no-sel?) + (let ([rest (cdr omissions)]) + (syntax-case (car omissions) (-selectors + -setters + -) + [-selectors + (loop rest names #t no-sel?)] + [-setters + (loop rest names no-set? #t)] + [(- name) + (identifier? (syntax name)) + (loop rest (cons (syntax name) names) + no-set? no-sel?)] + [else + (syntax-error who expr + "bad struct omission" + (car omissions))]))))] + [(name super-name) (if (identifier? name) + (values name #f) + (values (stx-car name) + (stx-car (stx-cdr name))))]) + (letrec ([names (build-struct-names + name fields + omit-selectors? omit-setters?)] + [filter + (lambda (names) + (cond + [(null? names) null] + [(ormap (lambda (x) (eq? (syntax-e (car names)) + (syntax-e x))) + omit-names) + (filter (cdr names))] + [else (cons (car names) (filter (cdr names)))]))]) + (loop (syntax rest) + (append + (if (null? omit-names) + names + (filter names)) + accum) + (cons (make-struct-info (syntax-e name) + (and super-name (syntax-e super-name)) + names) + struct-accum)))))] + [(struct . _) + (literal? struct) + (syntax-error who expr + "bad `struct' clause form" + (syntax something))] + [(unit name : sig) + (and (literal? unit) + (identifier? (syntax name))) + (let ([s (get-sig who expr (syntax name) (syntax sig))]) + (loop (syntax rest) + (cons s accum) + struct-accum))] + [(unit . _) + (literal? unit) + (syntax-error who expr + "bad `unit' clause form" + (syntax something))] + [(open sig) + (literal? open) + (let ([s (get-sig who expr #f (syntax sig))]) + (loop (syntax rest) + (append (signature-elems s) accum) + (append (signature-structs s) struct-accum)))] + [(open . _) + (literal? open) + (syntax-error who expr + "bad `open' clause form" + (syntax something))] + [else + (syntax-error who expr "improper signature clause type" + (syntax something))])] + [_else (syntax-error who expr "ill-formed signature" + body)]))]) (check-unique (map (lambda (elem) (cond @@ -248,13 +276,15 @@ (if (identifier? id) (syntax-e id) id)) - elems)))))) + elems)) + struct-infos)))) (define (intern-vector intern-box v) (if (and intern-box - (andmap symbol? (vector->list v))) + (equal? #() (cdr v)) + (andmap symbol? (vector->list (car v)))) (or (ormap (lambda (i) - (and (equal? v (cadr i)) + (and (equal? (car v) (caadr i)) (list 'unquote (car i)))) (unbox intern-box)) (let ([name (car (generate-temporaries '(idvec)))]) @@ -268,15 +298,23 @@ (lambda (sig intern-box) (intern-vector intern-box - (list->vector - (map - (lambda (v) - (if (symbol? v) - v - (cons - (signature-name v) - (explode-sig v intern-box)))) - (signature-elems sig)))))) + (cons + (list->vector + (map + (lambda (v) + (if (symbol? v) + v + (cons + (signature-name v) + (explode-sig v intern-box)))) + (signature-elems sig))) + (list->vector + (map + (lambda (v) + (list->vector (list* (struct-info-name v) + (struct-info-super-name v) + (struct-info-names v)))) + (signature-structs sig))))))) (define explode-named-sig (lambda (s intern-box) @@ -358,6 +396,120 @@ [(eq? (cadar renames) export-name) (caar renames)] [else (loop (cdr renames))])))) + + (define (make-struct-stx-decls sig prefix src-stx check?) + ;; If check? is #f, generates a syntax definition for %# for + ;; each struct form in `sig'. Used for imports. + ;; If check? is #t, generates an empty syntax "definition" that has + ;; the side-effect of checking %# against its expected shape. + ;; CURRENTLY, check? is always #f. + (let ([signame (and (or prefix (not check?)) + (signature-name sig))]) + (append + (apply + append + (map (lambda (s) + (make-struct-stx-decls (list s) + (if signame + (format "~a~a:" + (or prefix "") + signame) + prefix) + src-stx + check?)) + (filter signature? (signature-elems sig)))) + (map (lambda (si) + (let ([names (struct-info-names si)] + [pfx (lambda (s) + `(quote-syntax + ,(let ([id (string->symbol + (format "~a~a~a" + (or prefix "") + (if signame + (format "~a:" signame) + "") + (if (syntax? s) + (syntax-e s) + s)))]) + (datum->syntax-object src-stx id))))]) + (let* ([name (pfx + (format "~a%#" (struct-info-name si)))] + [check (if check? + (lambda (l) + `(verify-struct-shape ,name ,l)) + values)]) + `(define-syntaxes (,@(if check? null (list (cadr name)))) + ,(check + `(list-immutable ,(pfx (car names)) + ,(pfx (cadr names)) + ,(pfx (caddr names)) + ;; trailing #fs below mean that we don't know whether we have all the fields: + (list-immutable + ,@(map pfx (every-other (cdddr names))) + #f) + (list-immutable + ,@(map pfx (every-other (if (null? (cdddr names)) null (cddddr names)))) + #f))))))) + (signature-structs sig))))) + + ;; Could be called at expansion time from the result of a `unit/sig' expansion. + ;; NOT CURRENTLY USED. + (define (verify-struct-shape name shape) + (let ([v (syntax-local-value name (lambda () #f))] + [n (length (list-ref shape 3))]) + (unless (and (list? v) + (= (length v) 5) + (identifier? (car v)) + (module-identifier=? (car v) (car shape)) + (identifier? (cadr v)) + (module-identifier=? (cadr v) (cadr shape)) + (identifier? (caddr v)) + (module-identifier=? (caddr v) (caddr shape)) + (list? (list-ref v 3)) + (= (length (list-ref v 3)) n) + (andmap identifier? (list-ref v 3)) + (andmap module-identifier=? (list-ref v 3) (list-ref shape 3)) + (list? (list-ref v 4)) + (= (length (list-ref v 4)) n) + (andmap identifier? (list-ref v 4)) + (andmap module-identifier=? (list-ref v 4) (list-ref shape 4))) + (raise-syntax-error + 'unit/sig + (format "struct definition for `~a' within the unit does not match the export signature (~a)" + (let ([s (symbol->string (syntax-e name))]) + (substring s 0 (- (string-length s) 2))) + ;; Say why: + (cond + [(not v) "definition is missing or does not use `define-struct'"] + [(not (and (list? v) + (= (length v) 5) + (identifier? (car v)) + (identifier? (cadr v)) + (identifier? (caddr v)) + (list? (list-ref v 3)) + (andmap identifier? (list-ref v 3)) + (list? (list-ref v 4)) + (andmap identifier? (list-ref v 4)) + (= (length (list-ref v 4)) (length (list-ref v 3))))) + "compile-time struct information is stragely malformed"] + [(not (< (length (list-ref v 3)) n)) + "extra fields in definition"] + [(not (> (length (list-ref v 3)) n)) + "missing fields in definition"] + [else + "different field names or order"])))) + ;; Return 0 values to context + (values))) + + + (define (every-other l) + (let loop ([l l][r null]) + (cond + [(null? l) r] + [(null? (cdr l)) (cons (car l) r)] + [else (loop (cddr l) (cons (car l) r))]))) + + ;; ------------------------------------------------------------ (define check-signature-unit-body (lambda (sig a-unit renames who expr) @@ -474,7 +626,15 @@ (let loop ([pre-lines null][lines body][port #f][port-name #f][body null][vars null]) (cond [(and (null? pre-lines) (not port) (null? lines)) - (make-parse-unit imports renames vars body)] + (make-parse-unit imports + renames + vars + (lambda (src-stx) (apply append (map (lambda (i) (make-struct-stx-decls i #f src-stx #f)) imports))) + body + (lambda (src-stx) + ;; Disabled until we have a mechanism for declaring precise information in signatures: + ; (make-struct-stx-decls sig #f src-stx #t) + null))] [(and (null? pre-lines) (not port) (not (pair? lines))) (syntax-error 'unit/sig expr "improper body list form")] [else @@ -948,7 +1108,8 @@ 'dummy (apply append - (map sig-explode-pair-sigpart exports))) + (map sig-explode-pair-sigpart exports)) + null) interned-vectors) interned-vectors))))))] [_else (raise-syntax-error @@ -960,21 +1121,25 @@ (lambda (who rest expr) (parse-imports who #t #f expr rest))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (provide parse-unit - parse-compound-unit - parse-invoke-vars + parse-compound-unit + parse-invoke-vars - parse-unit-renames - parse-unit-imports - parse-unit-body + parse-unit-renames + parse-unit-imports + parse-unit-stxes + parse-unit-body + parse-unit-stx-checks - signature-vars - do-rename - get-sig - explode-sig - explode-named-sigs - check-signature-unit-body - flatten-signature - flatten-signatures)) + verify-struct-shape + + signature-vars + do-rename + get-sig + explode-sig + explode-named-sigs + check-signature-unit-body + flatten-signature + flatten-signatures)) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index a9f7c96..639dafc 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -15,7 +15,7 @@ (define insp (current-inspector)) ; for named structures (define-struct unit (num-imports exports go)) ; unit value - (define-struct (exn:unit struct:exn) ()) ; run-time exception + (define-struct (exn:unit exn) ()) ; run-time exception ;; For units with inferred names, generate a struct that prints using the name: (define (make-naming-constructor type name) @@ -125,8 +125,9 @@ ;; from syntax definitions. (let* ([definition? (lambda (id) - (or (module-identifier=? id (quote-syntax define-values)) - (module-identifier=? id (quote-syntax define-syntaxes))))] + (and (identifier? id) + (or (module-identifier=? id (quote-syntax define-values)) + (module-identifier=? id (quote-syntax define-syntaxes)))))] [all-defined-names/kinds (apply append diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss index 2222831..a640fb9 100644 --- a/collects/mzlib/unitsig.ss +++ b/collects/mzlib/unitsig.ss @@ -1,4 +1,9 @@ +;; This implementation of `unit/sig' was ported from the old v100 +;; implementation, and then hacked a bit to produce more compact +;; output, and finally mangled to handle the v200 `struct' (with +;; compile-time information). It's in dire need of an overhaul. + (module unitsig mzscheme (require "unit.ss") (require "private/sigmatch.ss") @@ -53,17 +58,20 @@ name)) (signature-vars sig)) expr)] - [body (reverse! (parse-unit-body a-unit))] + [body (append + ((parse-unit-stxes a-unit) expr) + (reverse! (parse-unit-body a-unit)) + ((parse-unit-stx-checks a-unit) expr))] [import-sigs (explode-named-sigs (parse-unit-imports a-unit) #f)] [export-sig (explode-sig sig #f)]) - (syntax - (make-unit/sig - (unit - (import . imports) - (export . exports) - . body) - (quote import-sigs) - (quote export-sig))))))]))) + (syntax/loc expr + (make-unit/sig + (unit + (import . imports) + (export . exports) + . body) + (quote import-sigs) + (quote export-sig))))))]))) (define-syntax compound-unit/sig (lambda (expr) @@ -91,7 +99,8 @@ [flat-exports (t flat-exports)] [exploded-imports (t exploded-imports)] [exploded-exports (t exploded-exports)] - [interned-vectors (t (unbox boxed-interned-symbol-vectors))]) + [interned-vectors (t (map (lambda (x) `(,(car x) (quote ,(cadr x)))) + (unbox boxed-interned-symbol-vectors)))]) (syntax/loc expr (let ([tagx uexpr] ... . interned-vectors) @@ -132,7 +141,7 @@ (quote invoke-unit/sig) (quote (invoke)) (list unt) - (quote (#())) + (quote ((#() . #()))) (quote (exploded-sigs))) (invoke-unit (unit/sig-unit u) . flat-sigs)))))])))