diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index aa851a4052..5f1248b43e 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -75,7 +75,9 @@ (if (null? stx-ids) null '(#%stx-array)) lift-ids) (map (lambda (stx id) - `(define ,id (#%decode-syntax ,(stx-encoded stx)))) + `(define ,id ,(if stx + `(#%decode-syntax ,(stx-encoded stx)) + #f))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -304,7 +306,8 @@ + - * / min max bitwise-and bitwise-ior arithmetic-shift vector-ref string-ref bytes-ref set-mcar! set-mcdr! cons mcons))] - [(4) (memq (car a) '(vector-set! string-set! bytes-set!))])) + [(4) (memq (car a) '(vector-set! string-set! bytes-set!))] + [else #f])) (cons '#%in a) a)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index f73b98d2ce..29b7b76f5b 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -306,7 +306,7 @@ ;; not sure if it's really unsigned (integer-bytes->integer (read-bytes 4 p) #f #f)) -(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns)) +(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns mpis)) (define (cp-getc cp) (begin-with-definitions @@ -430,6 +430,11 @@ ;; Synatx unmarshaling (define-form-struct wrapped (datum wraps certs)) +(define-form-struct lexical-rename (alist)) +(define-form-struct phase-shift (amt src dest)) +(define-form-struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) +(define-form-struct all-from-module (path phase src-phase exceptions prefix)) +(define-form-struct module-binding (path mod-phase import-phase id nominal-path nominal-phase nominal-id)) (define (decode-stx cp v) (if (integer? v) @@ -515,15 +520,107 @@ ;; a mark (string->symbol (format "mark~a" (car a)))] [(vector? a) - `(#%decode-lexical-rename ,a)] + (make-lexical-rename + (let ([top (+ (/ (- (vector-length a) 2) 2) 2)]) + (let loop ([i 2]) + (if (= i top) + null + (cons (cons (vector-ref a i) + (vector-ref a (+ (- top 2) i))) + (loop (+ i 1)))))))] [(pair? a) - `(#%decode-module-rename ,a)] + (let-values ([(plus-kern? a) (if (eq? (car a) #t) + (values #t (cdr a)) + (values #f a))]) + (match a + [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames) + (let-values ([(unmarshals renames mark-renames) + (if (vector? maybe-unmarshals) + (values null maybe-unmarshals renames) + (values maybe-unmarshals + (car renames) + (cdr renames)))]) + (make-module-rename phase + (if kind 'marked 'normal) + set-id + (map (lambda (u) + (let ([just-phase? (number? (cddr u))]) + (let-values ([(exns prefix) + (if just-phase? + (values null #f) + (let loop ([u (if just-phase? null (cdddr u))] + [a null]) + (if (pair? u) + (loop (cdr u) (cons (car u) a)) + (values (reverse a) u))))]) + (make-all-from-module + (parse-module-path-index cp (car u)) + (cadr u) + (if just-phase? + (cddr u) + (caddr u)) + exns + prefix)))) + unmarshals) + (let loop ([i 0]) + (if (= i (vector-length renames)) + null + (cons + (let ([key (vector-ref renames i)] + [make-mapping + (lambda (path mod-phase import-phase id nominal-path nominal-phase nominal-id) + (make-module-binding + (parse-module-path-index cp path) + mod-phase + import-phase + id + (parse-module-path-index cp nominal-path) + nominal-phase + (if (eq? id nominal-id) #t nominal-id)))]) + (cons key + (let ([m (vector-ref renames (add1 i))] + [parse-nominal-modidx-plus-phase + (lambda (modidx mod-phase exportname nominal-modidx-plus-phase nom-exportname) + (match nominal-modidx-plus-phase + [`(,nominal-modidx ,import-phase-plus-nominal-phase) + (match import-phase-plus-nominal-phase + [`(,import-phase ,nom-phase) + (make-mapping modidx mod-phase import-phase exportname + nominal-modidx nom-phase nom-exportname)] + [import-phase + (make-mapping modidx mod-phase import-phase exportname + modidx mod-phase nom-exportname)])] + [nominal-modidx + (make-mapping modidx mod-phase '* exportname + nominal-modidx mod-phase nom-exportname)]))]) + (match m + [`(,modidx ,mod-phase ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname) + (parse-nominal-modidx-plus-phase modidx mod-phase exportname + nominal-modidx-plus-phase nominal-exportname)] + [`(,modidx ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname) + (parse-nominal-modidx-plus-phase modidx '* exportname + nominal-modidx-plus-phase nominal-exportname)] + [`(,modidx ,nominal-modidx) + (make-mapping modidx '* '* key nominal-modidx '* key)] + [`(,modidx ,exportname) + (make-mapping modidx '* '* exportname modidx '* exportname)] + [modidx + (make-mapping modidx '* '* key modidx '* key)])))) + (loop (+ i 2))))) + mark-renames + (and plus-kern? 'plus-kern)))] + [else (error "bad module rename: ~e" a)]))] [(boolean? a) `(#%top-level-rename ,a)] [(symbol? a) '(#%mark-barrier)] [(box? a) - `(#%phase-shift ,(unbox a))] + (match (unbox a) + [`#(,amt ,src ,dest #f) + (make-phase-shift amt + (parse-module-path-index cp src) + (parse-module-path-index cp dest))] + [else (error 'parse "bad phase shift: ~e" a)])] [else (error 'decode-wraps "bad wrap element: ~e" a)]))) w))) @@ -544,6 +641,20 @@ (vector-set! (cport-symtab cp) pos v) (vector-set! (cport-decoded cp) pos #t)) +(define (parse-module-path-index cp s) + (cond + [(not s) #f] + [(module-path-index? s) + (hash-ref (cport-mpis cp) s + (lambda () + (let-values ([(name base) (module-path-index-split s)]) + (let ([v `(module-path-index-join + (quote ,name) + ,(parse-module-path-index cp base))]) + (hash-set! (cport-mpis cp) s v) + v))))] + [else `(quote ,s)])) + ;; ---------------------------------------- ;; Main parsing loop @@ -784,7 +895,7 @@ (define symtab (make-vector symtabsize (make-not-ready))) - (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash))) + (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for/list ([i (in-range 1 symtabsize)]) (when (not-ready? (vector-ref symtab i)) (set-cport-pos! cp (vector-ref so* (sub1 i))) diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index c860882047..ca90839973 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -1088,11 +1088,13 @@ (define max-call-head-width 5) - (define (no-sharing? expr count acdr) - (if (and found (hash-table-get found (acdr expr) #f)) + (define (no-sharing? expr count apair? acdr) + (if (and found + (apair? expr) + (hash-table-get found (acdr expr) #f)) #f (or (zero? count) - (no-sharing? (acdr expr) (sub1 count) acdr)))) + (no-sharing? (acdr expr) (sub1 count) apair? acdr)))) (define (style head expr apair? acar acdr) (case (look-in-style-table head) @@ -1100,22 +1102,22 @@ syntax-rules shared unless when) - (and (no-sharing? expr 1 acdr) + (and (no-sharing? expr 1 apair? acdr) pp-lambda)) ((if set! set!-values) - (and (no-sharing? expr 1 acdr) + (and (no-sharing? expr 1 apair? acdr) pp-if)) ((cond case-lambda) - (and (no-sharing? expr 0 acdr) + (and (no-sharing? expr 0 apair? acdr) pp-cond)) ((case class) - (and (no-sharing? expr 1 acdr) + (and (no-sharing? expr 1 apair? acdr) pp-case)) ((and or import export require require-for-syntax require-for-template provide link public private override rename inherit field init) - (and (no-sharing? expr 0 acdr) + (and (no-sharing? expr 0 apair? acdr) pp-and)) ((let letrec let* let-values letrec-values let*-values @@ -1126,20 +1128,21 @@ (symbol? (acar (acdr expr)))) 2 1) + apair? acdr) pp-let)) ((begin begin0) - (and (no-sharing? expr 0 acdr) + (and (no-sharing? expr 0 apair? acdr) pp-begin)) ((do letrec-syntaxes+values) - (and (no-sharing? expr 2 acdr) + (and (no-sharing? expr 2 apair? acdr) pp-do)) ((send syntax-case instantiate module) - (and (no-sharing? expr 2 acdr) + (and (no-sharing? expr 2 apair? acdr) pp-syntax-case)) ((make-object) - (and (no-sharing? expr 1 acdr) + (and (no-sharing? expr 1 apair? acdr) pp-make-object)) (else #f))) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 70e2c235a7..5886b1ba8b 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -3518,6 +3518,9 @@ static void sfs_note_app(SFS_Info *info, Scheme_Object *rator) { if (!info->pass) { if (!info->tail_pos) { + if (SAME_OBJ(scheme_values_func, rator)) + /* no need to clear for app of `values' */ + return; if (SCHEME_PRIMP(rator)) { int opt; opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK; diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 95fc7830c3..b619c3de83 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -5518,7 +5518,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, scheme_unmarshal_wrap_set(ut, local_key, a); } else if (SCHEME_PAIRP(a)) { /* A rename table: - - ([#t] [unmarshal] #( ...) + - ([#t] [unmarshal] #( ...) . (( ( . ) ...) ...)) ; <- marked_names where a is actually two values, one of: -